1 | module re_alloc |
---|
2 | |
---|
3 | interface realloc |
---|
4 | module procedure realloc_c1 |
---|
5 | module procedure realloc_r |
---|
6 | module procedure realloc_i |
---|
7 | !! subroutine realloc_c1(c,n,m,istat) |
---|
8 | !! character(len=1),pointer,dimension(:) :: c |
---|
9 | !! integer :: n,m |
---|
10 | !! integer :: istat |
---|
11 | !! end subroutine |
---|
12 | !! subroutine realloc_r(c,n,m,istat) |
---|
13 | !! real,pointer,dimension(:) :: c |
---|
14 | !! integer :: n,m |
---|
15 | !! integer :: istat |
---|
16 | !! end subroutine |
---|
17 | !! subroutine realloc_i(c,n,m,istat) |
---|
18 | !! integer,pointer,dimension(:) :: c |
---|
19 | !! integer :: n,m |
---|
20 | !! integer :: istat |
---|
21 | !! end subroutine |
---|
22 | end interface |
---|
23 | |
---|
24 | contains |
---|
25 | |
---|
26 | subroutine realloc_c1(c,n,m,istat) |
---|
27 | character(len=1),pointer,dimension(:) :: c |
---|
28 | integer,intent(in) :: n,m |
---|
29 | integer,intent(out) :: istat |
---|
30 | integer :: num |
---|
31 | character(len=1),pointer,dimension(:) :: tmp |
---|
32 | |
---|
33 | istat=0 |
---|
34 | if ( (n<0) .OR. (m<=0) ) then |
---|
35 | istat=10 |
---|
36 | return |
---|
37 | endif |
---|
38 | |
---|
39 | if ( .not. associated(c) ) then |
---|
40 | allocate(c(m),stat=istat) ! allocate new memory |
---|
41 | return |
---|
42 | endif |
---|
43 | |
---|
44 | tmp=>c ! save pointer to original mem |
---|
45 | nullify(c) |
---|
46 | allocate(c(m),stat=istat) ! allocate new memory |
---|
47 | if ( istat /= 0 ) then |
---|
48 | c=>tmp |
---|
49 | return |
---|
50 | endif |
---|
51 | if ( n /= 0 ) then |
---|
52 | num=min(n,m) |
---|
53 | c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. |
---|
54 | endif |
---|
55 | deallocate(tmp) ! deallocate original memory |
---|
56 | return |
---|
57 | end subroutine |
---|
58 | |
---|
59 | subroutine realloc_r(c,n,m,istat) |
---|
60 | real,pointer,dimension(:) :: c |
---|
61 | integer,intent(in) :: n,m |
---|
62 | integer,intent(out) :: istat |
---|
63 | integer :: num |
---|
64 | real,pointer,dimension(:) :: tmp |
---|
65 | |
---|
66 | istat=0 |
---|
67 | if ( (n<0) .OR. (m<=0) ) then |
---|
68 | istat=10 |
---|
69 | return |
---|
70 | endif |
---|
71 | |
---|
72 | if ( .not. associated(c) ) then |
---|
73 | allocate(c(m),stat=istat) ! allocate new memory |
---|
74 | return |
---|
75 | endif |
---|
76 | |
---|
77 | tmp=>c ! save pointer to original mem |
---|
78 | nullify(c) |
---|
79 | allocate(c(m),stat=istat) ! allocate new memory |
---|
80 | if ( istat /= 0 ) then |
---|
81 | c=>tmp |
---|
82 | return |
---|
83 | endif |
---|
84 | if ( n /= 0 ) then |
---|
85 | num=min(n,m) |
---|
86 | c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. |
---|
87 | endif |
---|
88 | deallocate(tmp) ! deallocate original memory |
---|
89 | return |
---|
90 | end subroutine |
---|
91 | |
---|
92 | subroutine realloc_i(c,n,m,istat) |
---|
93 | integer,pointer,dimension(:) :: c |
---|
94 | integer,intent(in) :: n,m |
---|
95 | integer,intent(out) :: istat |
---|
96 | integer :: num |
---|
97 | integer,pointer,dimension(:) :: tmp |
---|
98 | |
---|
99 | istat=0 |
---|
100 | if ( (n<0) .OR. (m<=0) ) then |
---|
101 | istat=10 |
---|
102 | return |
---|
103 | endif |
---|
104 | |
---|
105 | if ( .not. associated(c) ) then |
---|
106 | allocate(c(m),stat=istat) ! allocate new memory |
---|
107 | return |
---|
108 | endif |
---|
109 | |
---|
110 | tmp=>c ! save pointer to original mem |
---|
111 | nullify(c) |
---|
112 | allocate(c(m),stat=istat) ! allocate new memory |
---|
113 | if ( istat /= 0 ) then |
---|
114 | c=>tmp |
---|
115 | return |
---|
116 | endif |
---|
117 | if ( n /= 0 ) then |
---|
118 | num=min(n,m) |
---|
119 | c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. |
---|
120 | endif |
---|
121 | deallocate(tmp) ! deallocate original memory |
---|
122 | return |
---|
123 | end subroutine |
---|
124 | |
---|
125 | end module re_alloc |
---|