1 | MODULE memoir |
---|
2 | C**** |
---|
3 | C ***************************** |
---|
4 | C * OASIS ROUTINE - LEVEL 3 * |
---|
5 | C * ------------- ------- * |
---|
6 | C ***************************** |
---|
7 | C |
---|
8 | C**** *memoir* - F90 interface for dynamic allocation in FSCINT |
---|
9 | C |
---|
10 | C Purpose: |
---|
11 | C ------- |
---|
12 | C Handle dynamic allocation in FSCINT |
---|
13 | C |
---|
14 | C** Interface: |
---|
15 | C --------- |
---|
16 | C *CALL* *memoir(r-i)(pw,koff,ksize,koldsize) |
---|
17 | C |
---|
18 | C Input: |
---|
19 | C ----- |
---|
20 | C pw : array to be allocated |
---|
21 | C ksize : new size to be allocated |
---|
22 | C koldsize : old size of allocation |
---|
23 | C |
---|
24 | C Output: |
---|
25 | C ------ |
---|
26 | C koff : status flag |
---|
27 | C |
---|
28 | C Workspace: |
---|
29 | C --------- |
---|
30 | C None |
---|
31 | C |
---|
32 | C Externals: |
---|
33 | C --------- |
---|
34 | C None |
---|
35 | C |
---|
36 | C Reference: |
---|
37 | C --------- |
---|
38 | C This F90 module handles dynamic allocation within FSCINT. |
---|
39 | C It deals with both INTEGER and REAL memory allocation. |
---|
40 | C It has been tested on a variety of platforms (SGI, VPP, T3E, C90) |
---|
41 | C and is truly portable. The compilation step may vary across |
---|
42 | C platforms (see OASIS documentation 2.2). The module has been |
---|
43 | C written with fixed format and should then be named with suffix .f |
---|
44 | C |
---|
45 | C History: |
---|
46 | C ------- |
---|
47 | C Version Programmer Date Description |
---|
48 | C ------- ---------- ---- ----------- |
---|
49 | C 2.2 A. Piacentini 97/09/15 Created |
---|
50 | C 2.3 A. Piacentini 98/10/01 Modified: Bug corrected in case |
---|
51 | C of reallocation |
---|
52 | C |
---|
53 | C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
---|
54 | C* ------------------------------------------------------------------ |
---|
55 | C |
---|
56 | C* ---------------------------- Poema verses ---------------------------- |
---|
57 | C |
---|
58 | C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
---|
59 | C |
---|
60 | C* Block interface |
---|
61 | C |
---|
62 | INTERFACE memoirh |
---|
63 | MODULE PROCEDURE memoirr,memoiri |
---|
64 | END INTERFACE |
---|
65 | C |
---|
66 | CONTAINS |
---|
67 | C |
---|
68 | C* Real allocation |
---|
69 | C |
---|
70 | SUBROUTINE memoirr(pw,koff,ksize,koldsize) |
---|
71 | C |
---|
72 | USE mod_kinds_oasis |
---|
73 | REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: pw |
---|
74 | INTEGER (kind=ip_intwp_p) :: koff |
---|
75 | INTEGER (kind=ip_intwp_p) :: ksize |
---|
76 | INTEGER (kind=ip_intwp_p) :: koldsize |
---|
77 | C |
---|
78 | REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: aw |
---|
79 | INTEGER (kind=ip_intwp_p) :: ierr |
---|
80 | C |
---|
81 | C PRINT *,'memoirR ksize ',ksize |
---|
82 | C |
---|
83 | IF (ksize > 0) THEN |
---|
84 | IF (koldsize > 0) THEN |
---|
85 | allocate(aw(ksize),stat=ierr) |
---|
86 | C PRINT *,'ierr= ',ierr |
---|
87 | IF(.NOT. associated(aw)) PRINT *,'memoirR Something Wrong' |
---|
88 | koff=1 |
---|
89 | aw(1:koldsize)=pw |
---|
90 | deallocate(pw,stat=ierr) |
---|
91 | C PRINT *,'memoirR dealloc of old pw ierr= ',ierr |
---|
92 | pw=>aw |
---|
93 | ELSE |
---|
94 | allocate(pw(ksize),stat=ierr) |
---|
95 | C PRINT *,'ierr= ',ierr |
---|
96 | IF(.NOT. associated(pw)) PRINT *,'memoirR Something Wrong' |
---|
97 | C |
---|
98 | C PRINT *,'memoirR allocated' |
---|
99 | C |
---|
100 | koff=1 |
---|
101 | ENDIF |
---|
102 | ELSE |
---|
103 | IF(associated(pw)) THEN |
---|
104 | deallocate(pw,stat=ierr) |
---|
105 | C PRINT *,'memoirR dealloc ierr= ',ierr |
---|
106 | ELSE |
---|
107 | STOP 'error in memoirR deallocation' |
---|
108 | END IF |
---|
109 | C |
---|
110 | C PRINT *,'memoirR deallocated' |
---|
111 | C |
---|
112 | ENDIF |
---|
113 | C |
---|
114 | END SUBROUTINE memoirr |
---|
115 | C |
---|
116 | C* Integer allocation |
---|
117 | C |
---|
118 | SUBROUTINE memoiri(kw,koff,ksize,koldsize) |
---|
119 | C |
---|
120 | USE mod_kinds_oasis |
---|
121 | INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER :: kw |
---|
122 | INTEGER (kind=ip_intwp_p) :: koff |
---|
123 | INTEGER (kind=ip_intwp_p) :: ksize |
---|
124 | INTEGER (kind=ip_intwp_p) :: koldsize |
---|
125 | C |
---|
126 | INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER :: iw |
---|
127 | INTEGER (kind=ip_intwp_p) :: ierr |
---|
128 | C |
---|
129 | C PRINT *,'memoirI ksize ',ksize |
---|
130 | C |
---|
131 | IF (ksize > 0) THEN |
---|
132 | IF (koldsize > 0) THEN |
---|
133 | allocate(iw(ksize),stat=ierr) |
---|
134 | C PRINT *,'ierr= ',ierr |
---|
135 | IF(.NOT. associated(iw)) PRINT *,'memoirI Something Wrong' |
---|
136 | koff=1 |
---|
137 | iw(1:koldsize)=kw |
---|
138 | deallocate(kw,stat=ierr) |
---|
139 | C PRINT *,'memoirI dealloc of old kw ierr= ',ierr |
---|
140 | kw=>iw |
---|
141 | ELSE |
---|
142 | allocate(kw(ksize),stat=ierr) |
---|
143 | C PRINT *,'ierr= ',ierr |
---|
144 | IF(.NOT. associated(kw)) PRINT *,'memoirI Something Wrong' |
---|
145 | C |
---|
146 | C PRINT *,'memoirI allocated' |
---|
147 | C |
---|
148 | koff=1 |
---|
149 | ENDIF |
---|
150 | ELSE |
---|
151 | IF(associated(kw)) THEN |
---|
152 | deallocate(kw,stat=ierr) |
---|
153 | C PRINT *,'memoirI dealloc ierr= ',ierr |
---|
154 | ELSE |
---|
155 | STOP 'error in memoirI deallocation' |
---|
156 | END IF |
---|
157 | C |
---|
158 | C PRINT *,'memoirI deallocated' |
---|
159 | C |
---|
160 | ENDIF |
---|
161 | C |
---|
162 | END SUBROUTINE memoiri |
---|
163 | C |
---|
164 | END MODULE memoir |
---|
165 | |
---|
166 | |
---|
167 | |
---|
168 | |
---|