1 | MODULE wrk_nemo_2 |
---|
2 | !!====================================================================== |
---|
3 | !! *** MODULE wrk_nemo *** |
---|
4 | !! NEMO work space: define and allocate work-space arrays used in |
---|
5 | !! all components of NEMO |
---|
6 | !!====================================================================== |
---|
7 | !! History : 4.0 ! 2011-01 (A Porter) Original code |
---|
8 | !!---------------------------------------------------------------------- |
---|
9 | |
---|
10 | !!---------------------------------------------------------------------- |
---|
11 | !! wrk_alloc : define in memory the work space arrays |
---|
12 | !! wrk_in_use, iwrk_in_use, wrk_in_use_xz : check the availability of a workspace |
---|
13 | !! wrk_not_released, iwrk_not_released, wrk_not_released_xz : release the workspace |
---|
14 | !! print_in_use_list : print out the table holding which workspace arrays are currently marked as in use |
---|
15 | !! get_next_arg : get the next argument |
---|
16 | !! wrk_stop : act as local alternative to ctl_stop |
---|
17 | !!---------------------------------------------------------------------- |
---|
18 | USE par_oce ! ocean parameters |
---|
19 | |
---|
20 | IMPLICIT NONE |
---|
21 | PRIVATE |
---|
22 | |
---|
23 | |
---|
24 | INTERFACE nemo_allocate |
---|
25 | MODULE PROCEDURE nemo_allocate_4d, nemo_allocate_3d, nemo_allocate_2d, & |
---|
26 | & nemo_allocate_1d, nemo_allocate_2d_i |
---|
27 | END INTERFACE |
---|
28 | |
---|
29 | INTERFACE nemo_deallocate |
---|
30 | MODULE PROCEDURE nemo_deallocate_4d, nemo_deallocate_3d, nemo_deallocate_2d, & |
---|
31 | & nemo_deallocate_1d, nemo_deallocate_2d_i |
---|
32 | END INTERFACE |
---|
33 | PUBLIC wrk_alloc_2, nemo_allocate, nemo_deallocate |
---|
34 | |
---|
35 | |
---|
36 | INTEGER, PARAMETER :: num_1d_wrkspaces = 27 ! No. of 1D workspace arrays ( MAX(jpi*jpj,jpi*jpk,jpj*jpk) ) |
---|
37 | INTEGER, PARAMETER :: num_2d_wrkspaces = 35 ! No. of 2D workspace arrays (jpi,jpj) |
---|
38 | INTEGER, PARAMETER :: num_3d_wrkspaces = 15 ! No. of 3D workspace arrays (jpi,jpj,jpk) |
---|
39 | INTEGER, PARAMETER :: num_4d_wrkspaces = 4 ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts) |
---|
40 | |
---|
41 | |
---|
42 | INTEGER, PARAMETER :: num_xz_wrkspaces = 4 ! No. of 2D, xz workspace arrays (jpi,jpk) |
---|
43 | |
---|
44 | INTEGER, PARAMETER :: num_1d_lwrkspaces = 0 ! No. of 1D logical workspace arrays |
---|
45 | INTEGER, PARAMETER :: num_2d_lwrkspaces = 3 ! No. of 2D logical workspace arrays |
---|
46 | INTEGER, PARAMETER :: num_3d_lwrkspaces = 1 ! No. of 3D logical workspace arrays |
---|
47 | INTEGER, PARAMETER :: num_4d_lwrkspaces = 0 ! No. of 4D logical workspace arrays |
---|
48 | |
---|
49 | INTEGER, PARAMETER :: num_1d_iwrkspaces = 0 ! No. of 1D integer workspace arrays |
---|
50 | INTEGER, PARAMETER :: num_2d_iwrkspaces = 1 ! No. of 2D integer workspace arrays |
---|
51 | INTEGER, PARAMETER :: num_3d_iwrkspaces = 0 ! No. of 3D integer workspace arrays |
---|
52 | INTEGER, PARAMETER :: num_4d_iwrkspaces = 0 ! No. of 4D integer workspace arrays |
---|
53 | ! Maximum no. of workspaces of any one dimensionality that can be |
---|
54 | ! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces, num_4d_wrkspaces) |
---|
55 | INTEGER :: max_num_wrkspaces = 35 |
---|
56 | |
---|
57 | ! If adding more arrays here, remember to increment the appropriate |
---|
58 | ! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc() |
---|
59 | TYPE work_space_1d |
---|
60 | LOGICAL :: in_use |
---|
61 | REAL(wp), DIMENSION(:), POINTER :: wrk |
---|
62 | END TYPE |
---|
63 | TYPE(work_space_1d), DIMENSION(num_1d_wrkspaces) :: s_wrk_1d |
---|
64 | INTEGER :: n_wrk_1d |
---|
65 | |
---|
66 | TYPE work_space_2d |
---|
67 | LOGICAL :: in_use |
---|
68 | REAL(wp), DIMENSION(:,:), POINTER:: wrk |
---|
69 | END TYPE |
---|
70 | TYPE(work_space_2d), DIMENSION(num_2d_wrkspaces) :: s_wrk_2d |
---|
71 | INTEGER :: n_wrk_2d |
---|
72 | |
---|
73 | TYPE work_space_xz |
---|
74 | LOGICAL :: in_use |
---|
75 | REAL(wp), DIMENSION(:,:), POINTER :: wrk |
---|
76 | END TYPE |
---|
77 | TYPE(work_space_xz), DIMENSION(num_xz_wrkspaces) :: s_wrk_xz |
---|
78 | INTEGER :: n_wrk_xz |
---|
79 | |
---|
80 | TYPE work_space_3d |
---|
81 | LOGICAL :: in_use |
---|
82 | REAL(wp), DIMENSION(:,:,:), POINTER :: wrk |
---|
83 | END TYPE |
---|
84 | TYPE(work_space_3d), DIMENSION(num_3d_wrkspaces) :: s_wrk_3d |
---|
85 | INTEGER :: n_wrk_3d |
---|
86 | |
---|
87 | TYPE work_space_4d |
---|
88 | LOGICAL :: in_use |
---|
89 | REAL(wp), DIMENSION(:,:,:,:), POINTER :: wrk |
---|
90 | END TYPE |
---|
91 | TYPE(work_space_4d), DIMENSION(num_4d_wrkspaces) :: s_wrk_4d |
---|
92 | INTEGER :: n_wrk_4d |
---|
93 | |
---|
94 | TYPE work_space_2d_i |
---|
95 | LOGICAL :: in_use |
---|
96 | INTEGER, DIMENSION(:,:), POINTER :: wrk |
---|
97 | END TYPE |
---|
98 | TYPE(work_space_2d_i), DIMENSION(num_2d_iwrkspaces) :: s_wrk_2d_i |
---|
99 | INTEGER :: n_wrk_2d_i |
---|
100 | |
---|
101 | |
---|
102 | ! Labels for specifying workspace type in call to print_in_use_list() |
---|
103 | INTEGER, PARAMETER :: INTEGER_TYPE = 0 |
---|
104 | INTEGER, PARAMETER :: LOGICAL_TYPE = 1 |
---|
105 | INTEGER, PARAMETER :: REAL_TYPE = 2 |
---|
106 | |
---|
107 | INTEGER :: kumout ! Local copy of numout unit number for error/warning messages |
---|
108 | LOGICAL :: llwp ! Local copy of lwp - whether we are master PE or not |
---|
109 | |
---|
110 | CHARACTER(LEN=*), PARAMETER :: cform_err2 = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: |
---|
111 | CHARACTER(LEN=*), PARAMETER :: cform_war2 = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: |
---|
112 | |
---|
113 | !!---------------------------------------------------------------------- |
---|
114 | !! NEMO/OPA 4.0 , NEMO Consortium (2011) |
---|
115 | !! $Id:$ |
---|
116 | !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) |
---|
117 | !!---------------------------------------------------------------------- |
---|
118 | CONTAINS |
---|
119 | |
---|
120 | FUNCTION wrk_alloc_2(iunit, lwp_arg) |
---|
121 | !!---------------------------------------------------------------------- |
---|
122 | !! *** FUNCTION wrk_alloc *** |
---|
123 | !! |
---|
124 | !! ** Purpose : Define in memory once for all the NEMO 2D, 3D and 4d |
---|
125 | !! work space arrays |
---|
126 | !!---------------------------------------------------------------------- |
---|
127 | INTEGER, INTENT(in) :: iunit ! Unit no. to use for error/warning messages in this module |
---|
128 | LOGICAL, INTENT(in) :: lwp_arg ! Value of lwp |
---|
129 | ! |
---|
130 | INTEGER :: ji |
---|
131 | INTEGER :: wrk_alloc_2 ! Return value |
---|
132 | INTEGER :: extent_1d ! Extent to allocate for 1D arrays |
---|
133 | INTEGER, DIMENSION(:), ALLOCATABLE :: ierror ! local integer |
---|
134 | !!---------------------------------------------------------------------- |
---|
135 | ! |
---|
136 | ! Save the unit number to use for err/warning messages |
---|
137 | kumout = iunit |
---|
138 | ! Save whether we are master PE or not (for output messages) |
---|
139 | llwp = lwp_arg |
---|
140 | ! |
---|
141 | ALLOCATE(ierror(num_1d_wrkspaces+num_2d_wrkspaces+num_3d_wrkspaces & |
---|
142 | & + num_4d_wrkspaces+num_xz_wrkspaces+num_2d_iwrkspaces) ) |
---|
143 | ! |
---|
144 | ! Extent to use for 1D work arrays - find the maximum product of |
---|
145 | ! jpi*jpj, jpi*jpk and jpj*jpk and use that |
---|
146 | IF ( jpi < jpj .AND. jpi < jpk ) THEN ; extent_1d = jpj*jpk |
---|
147 | ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN ; extent_1d = jpi*jpk |
---|
148 | ELSE ; extent_1d = jpi*jpj |
---|
149 | ENDIF |
---|
150 | ! |
---|
151 | ierror(:) = 0 |
---|
152 | ! |
---|
153 | n_wrk_1d = 1 |
---|
154 | n_wrk_2d = 1 |
---|
155 | n_wrk_3d = 1 |
---|
156 | n_wrk_4d = 1 |
---|
157 | n_wrk_xz = 1 |
---|
158 | n_wrk_2d_i = 1 |
---|
159 | |
---|
160 | DO ji = 1, num_1d_wrkspaces |
---|
161 | s_wrk_1d(ji)%in_use = .FALSE. |
---|
162 | ALLOCATE( s_wrk_1d(ji)%wrk(extent_1d), STAT=ierror(ji) ) |
---|
163 | END DO |
---|
164 | DO ji = 1, num_2d_wrkspaces |
---|
165 | s_wrk_2d(ji)%in_use = .FALSE. |
---|
166 | ALLOCATE( s_wrk_2d(ji)%wrk(jpi,jpj), STAT=ierror(ji+num_1d_wrkspaces) ) |
---|
167 | END DO |
---|
168 | DO ji = 1, num_3d_wrkspaces |
---|
169 | s_wrk_3d(ji)%in_use = .FALSE. |
---|
170 | ALLOCATE( s_wrk_3d(ji)%wrk(jpi,jpj,jpk), STAT=ierror(ji+num_2d_wrkspaces) ) |
---|
171 | END DO |
---|
172 | DO ji = 1, num_4d_wrkspaces |
---|
173 | s_wrk_4d(ji)%in_use = .FALSE. |
---|
174 | ALLOCATE( s_wrk_4d(ji)%wrk(jpi,jpj,jpk,jpts), STAT=ierror(ji+num_3d_wrkspaces) ) |
---|
175 | END DO |
---|
176 | DO ji = 1, num_xz_wrkspaces |
---|
177 | s_wrk_xz(ji)%in_use = .FALSE. |
---|
178 | ALLOCATE( s_wrk_xz(ji)%wrk(jpi,jpk), STAT=ierror(ji+num_4d_wrkspaces) ) |
---|
179 | END DO |
---|
180 | DO ji = 1, num_2d_iwrkspaces |
---|
181 | s_wrk_2d_i(ji)%in_use = .FALSE. |
---|
182 | ALLOCATE( s_wrk_2d_i(ji)%wrk(jpi,jpj), STAT=ierror(ji+num_xz_wrkspaces) ) |
---|
183 | END DO |
---|
184 | ! |
---|
185 | wrk_alloc_2 = MAXVAL( ierror ) |
---|
186 | ! |
---|
187 | ! Calling routine, nemo_alloc(), checks for errors and takes |
---|
188 | ! appropriate action - we just print a warning message |
---|
189 | IF( wrk_alloc_2 /= 0 ) THEN |
---|
190 | WRITE(kumout,cform_war2) |
---|
191 | WRITE(kumout,*) 'wrk_alloc: allocation of workspace arrays failed' |
---|
192 | ENDIF |
---|
193 | ! |
---|
194 | END FUNCTION wrk_alloc_2 |
---|
195 | |
---|
196 | |
---|
197 | SUBROUTINE nemo_allocate_4d( ptab4d, pidim, pjdim, pkdim, pldim ) |
---|
198 | REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: ptab4d |
---|
199 | INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim, pkdim, pldim |
---|
200 | ! |
---|
201 | INTEGER :: ji, jx, jy, jz, jt |
---|
202 | |
---|
203 | IF( PRESENT(pidim) ) THEN |
---|
204 | jx = pidim |
---|
205 | jy = pjdim |
---|
206 | jz = pkdim |
---|
207 | jt = pldim |
---|
208 | ELSE |
---|
209 | jx = jpi |
---|
210 | jy = jpj |
---|
211 | jz = jpk |
---|
212 | jt = jpts |
---|
213 | ENDIF |
---|
214 | |
---|
215 | ptab4d => s_wrk_4d(n_wrk_4d)%wrk(1:jx,1:jy,1:jz,1:jt) |
---|
216 | s_wrk_4d(n_wrk_4d)%in_use = .TRUE. |
---|
217 | n_wrk_4d = n_wrk_4d + 1 |
---|
218 | |
---|
219 | END SUBROUTINE nemo_allocate_4d |
---|
220 | |
---|
221 | SUBROUTINE nemo_allocate_3d( ptab3d, pidim, pjdim, pkdim ) |
---|
222 | REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: ptab3d |
---|
223 | INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim, pkdim |
---|
224 | ! |
---|
225 | INTEGER :: ji, jx, jy, jz |
---|
226 | |
---|
227 | IF( PRESENT(pidim) ) THEN |
---|
228 | jx = pidim |
---|
229 | jy = pjdim |
---|
230 | jz = pkdim |
---|
231 | ELSE |
---|
232 | jx = jpi |
---|
233 | jy = jpj |
---|
234 | jz = jpk |
---|
235 | ENDIF |
---|
236 | |
---|
237 | ptab3d => s_wrk_3d(n_wrk_3d)%wrk(1:jx,1:jy,1:jz) |
---|
238 | s_wrk_3d(n_wrk_3d)%in_use = .TRUE. |
---|
239 | n_wrk_3d = n_wrk_3d + 1 |
---|
240 | |
---|
241 | END SUBROUTINE nemo_allocate_3d |
---|
242 | |
---|
243 | SUBROUTINE nemo_allocate_2d( ptab2d, pidim, pjdim ) |
---|
244 | REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d |
---|
245 | INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim |
---|
246 | ! |
---|
247 | INTEGER :: jx, jy |
---|
248 | |
---|
249 | IF( PRESENT(pidim) ) THEN |
---|
250 | jx = pidim |
---|
251 | jy = pjdim |
---|
252 | ptab2d => s_wrk_xz(n_wrk_xz)%wrk(1:jx,1:jy) |
---|
253 | s_wrk_xz(n_wrk_xz)%in_use = .TRUE. |
---|
254 | n_wrk_xz = n_wrk_xz + 1 |
---|
255 | ELSE |
---|
256 | jx = jpi |
---|
257 | jy = jpj |
---|
258 | ptab2d => s_wrk_2d(n_wrk_2d)%wrk(:,:) |
---|
259 | s_wrk_2d(n_wrk_2d)%in_use = .TRUE. |
---|
260 | n_wrk_2d = n_wrk_2d + 1 |
---|
261 | ENDIF |
---|
262 | |
---|
263 | END SUBROUTINE nemo_allocate_2d |
---|
264 | |
---|
265 | SUBROUTINE nemo_allocate_1d( ptab1d ) |
---|
266 | REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: ptab1d |
---|
267 | ! |
---|
268 | |
---|
269 | ptab1d => s_wrk_1d(n_wrk_1d)%wrk(:) |
---|
270 | s_wrk_1d(n_wrk_1d)%in_use = .TRUE. |
---|
271 | n_wrk_1d = n_wrk_1d + 1 |
---|
272 | |
---|
273 | END SUBROUTINE nemo_allocate_1d |
---|
274 | |
---|
275 | SUBROUTINE nemo_allocate_2d_i( ptab2d ) |
---|
276 | INTEGER, POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d |
---|
277 | ! |
---|
278 | INTEGER :: ji |
---|
279 | LOGICAL :: l_in_use |
---|
280 | |
---|
281 | ptab2d => s_wrk_2d_i(n_wrk_2d_i)%wrk(:,:) |
---|
282 | s_wrk_2d_i(n_wrk_2d)%in_use = .TRUE. |
---|
283 | n_wrk_2d_i = n_wrk_2d_i + 1 |
---|
284 | |
---|
285 | END SUBROUTINE nemo_allocate_2d_i |
---|
286 | |
---|
287 | SUBROUTINE nemo_deallocate_4d( ptab4d ) |
---|
288 | REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: ptab4d |
---|
289 | |
---|
290 | NULLIFY(ptab4d) |
---|
291 | s_wrk_4d(n_wrk_4d)%in_use = .FALSE. |
---|
292 | n_wrk_4d = n_wrk_4d - 1 |
---|
293 | |
---|
294 | END SUBROUTINE nemo_deallocate_4d |
---|
295 | |
---|
296 | SUBROUTINE nemo_deallocate_3d( ptab3d) |
---|
297 | REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: ptab3d |
---|
298 | ! |
---|
299 | |
---|
300 | NULLIFY(ptab3d) |
---|
301 | s_wrk_3d(n_wrk_3d)%in_use = .FALSE. |
---|
302 | n_wrk_3d = n_wrk_3d - 1 |
---|
303 | |
---|
304 | END SUBROUTINE nemo_deallocate_3d |
---|
305 | |
---|
306 | SUBROUTINE nemo_deallocate_2d( ptab2d, pidim, pjdim ) |
---|
307 | REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d |
---|
308 | INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim |
---|
309 | ! |
---|
310 | INTEGER :: jx, jy |
---|
311 | |
---|
312 | IF( PRESENT(pidim) ) THEN |
---|
313 | jx = pidim |
---|
314 | jy = pjdim |
---|
315 | NULLIFY(ptab2d) |
---|
316 | s_wrk_xz(n_wrk_xz)%in_use = .FALSE. |
---|
317 | n_wrk_xz = n_wrk_xz - 1 |
---|
318 | ELSE |
---|
319 | jx = jpi |
---|
320 | jy = jpj |
---|
321 | NULLIFY(ptab2d) |
---|
322 | s_wrk_2d(n_wrk_2d)%in_use = .FALSE. |
---|
323 | n_wrk_2d = n_wrk_2d - 1 |
---|
324 | ENDIF |
---|
325 | |
---|
326 | END SUBROUTINE nemo_deallocate_2d |
---|
327 | |
---|
328 | SUBROUTINE nemo_deallocate_1d( ptab1d ) |
---|
329 | REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: ptab1d |
---|
330 | ! |
---|
331 | |
---|
332 | NULLIFY(ptab1d) |
---|
333 | s_wrk_1d(n_wrk_1d)%in_use = .FALSE. |
---|
334 | n_wrk_1d = n_wrk_1d - 1 |
---|
335 | |
---|
336 | END SUBROUTINE nemo_deallocate_1d |
---|
337 | |
---|
338 | SUBROUTINE nemo_deallocate_2d_i( ptab2d ) |
---|
339 | INTEGER, POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d |
---|
340 | ! |
---|
341 | |
---|
342 | NULLIFY(ptab2d) |
---|
343 | s_wrk_2d_i(n_wrk_2d)%in_use = .FALSE. |
---|
344 | n_wrk_2d_i = n_wrk_2d_i - 1 |
---|
345 | |
---|
346 | END SUBROUTINE nemo_deallocate_2d_i |
---|
347 | |
---|
348 | |
---|
349 | SUBROUTINE print_in_use_list( kdim, itype, in_use_list ) |
---|
350 | !!---------------------------------------------------------------------- |
---|
351 | !! *** ROUTINE print_in_use_list *** |
---|
352 | !! |
---|
353 | !! ** Purpose: to print out the table holding which workspace arrays |
---|
354 | !! are currently marked as in use. |
---|
355 | !!---------------------------------------------------------------------- |
---|
356 | INTEGER, INTENT(in) :: kdim |
---|
357 | INTEGER, INTENT(in) :: itype |
---|
358 | LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list |
---|
359 | ! |
---|
360 | INTEGER :: ji, icount |
---|
361 | CHARACTER(LEN=7) :: type_string |
---|
362 | !!---------------------------------------------------------------------- |
---|
363 | ! |
---|
364 | IF(.NOT. llwp) RETURN |
---|
365 | ! |
---|
366 | SELECT CASE ( kdim ) |
---|
367 | ! |
---|
368 | CASE (1) |
---|
369 | SELECT CASE (itype) |
---|
370 | CASE (INTEGER_TYPE) ; icount = num_1d_iwrkspaces |
---|
371 | CASE (LOGICAL_TYPE) ; icount = num_1d_lwrkspaces |
---|
372 | CASE (REAL_TYPE ) ; icount = num_1d_wrkspaces |
---|
373 | END SELECT |
---|
374 | ! |
---|
375 | CASE (2) |
---|
376 | SELECT CASE (itype) |
---|
377 | CASE (INTEGER_TYPE) ; icount = num_2d_iwrkspaces |
---|
378 | CASE (LOGICAL_TYPE) ; icount = num_2d_lwrkspaces |
---|
379 | CASE (REAL_TYPE ) ; icount = num_2d_wrkspaces |
---|
380 | END SELECT |
---|
381 | ! |
---|
382 | CASE (3) |
---|
383 | SELECT CASE (itype) |
---|
384 | CASE (INTEGER_TYPE) ; icount = num_3d_iwrkspaces |
---|
385 | CASE (LOGICAL_TYPE) ; icount = num_3d_lwrkspaces |
---|
386 | CASE (REAL_TYPE ) ; icount = num_3d_wrkspaces |
---|
387 | END SELECT |
---|
388 | ! |
---|
389 | CASE (4) |
---|
390 | SELECT CASE (itype) |
---|
391 | CASE (INTEGER_TYPE) ; icount = num_4d_iwrkspaces |
---|
392 | CASE (LOGICAL_TYPE) ; icount = num_4d_lwrkspaces |
---|
393 | CASE (REAL_TYPE ) ; icount = num_4d_wrkspaces |
---|
394 | END SELECT |
---|
395 | ! |
---|
396 | CASE DEFAULT ; RETURN |
---|
397 | ! |
---|
398 | END SELECT |
---|
399 | ! |
---|
400 | ! Set character string with type of workspace |
---|
401 | SELECT CASE (itype) |
---|
402 | CASE (INTEGER_TYPE) ; type_string = "INTEGER" |
---|
403 | CASE (LOGICAL_TYPE) ; type_string = "LOGICAL" |
---|
404 | CASE (REAL_TYPE ) ; type_string = "REAL" |
---|
405 | END SELECT |
---|
406 | ! |
---|
407 | WRITE(kumout,*) |
---|
408 | WRITE(kumout,"('------------------------------------------')") |
---|
409 | WRITE(kumout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string) |
---|
410 | WRITE(kumout,"('Workspace In use')") |
---|
411 | DO ji = 1, icount, 1 |
---|
412 | WRITE(kumout,"(4x,I2,8x,L1)") ji, in_use_list(ji) |
---|
413 | END DO |
---|
414 | WRITE(kumout,"('------------------------------------------')") |
---|
415 | WRITE(kumout,*) |
---|
416 | ! |
---|
417 | END SUBROUTINE print_in_use_list |
---|
418 | |
---|
419 | |
---|
420 | SUBROUTINE wrk_stop(cmsg) |
---|
421 | !!---------------------------------------------------------------------- |
---|
422 | !! *** ROUTINE wrk_stop *** |
---|
423 | !! ** Purpose : to act as local alternative to ctl_stop. |
---|
424 | !! Avoids dependency on in_out_manager module. |
---|
425 | !!---------------------------------------------------------------------- |
---|
426 | CHARACTER(LEN=*), INTENT(in) :: cmsg |
---|
427 | !!---------------------------------------------------------------------- |
---|
428 | ! |
---|
429 | WRITE(kumout, cform_err2) |
---|
430 | WRITE(kumout,*) TRIM(cmsg) |
---|
431 | ! ARPDBG - would like to call mppstop here to force a stop but that |
---|
432 | ! introduces a dependency on lib_mpp. Could call mpi_abort() directly |
---|
433 | ! but that's fairly brutal. Better to rely on calling routine to |
---|
434 | ! deal with the error passed back from the wrk_X routine? |
---|
435 | !CALL mppstop |
---|
436 | ! |
---|
437 | END SUBROUTINE wrk_stop |
---|
438 | |
---|
439 | !!===================================================================== |
---|
440 | END MODULE wrk_nemo_2 |
---|