New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
wrk_nemo.F90 in branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 2590

Last change on this file since 2590 was 2590, checked in by trackstand2, 13 years ago

Merge branch 'dynamic_memory' into master-svn-dyn
File size: 46.8 KB
Line 
1MODULE wrk_nemo
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   USE par_oce        ! ocean parameters
10   USE in_out_manager ! I/O manager
11
12   IMPLICIT NONE
13   PRIVATE
14
15   PUBLIC wrk_alloc   ! routine called in nemogcm module (nemo_init routine)
16   PUBLIC wrk_use,     llwrk_use,     iwrk_use,     wrk_use_xz
17   PUBLIC wrk_release, llwrk_release, iwrk_release, wrk_release_xz
18
19   INTEGER, PARAMETER :: num_1d_wrkspaces  = 27 ! No. of 1D workspace arrays ( MAX(jpi*jpj,jpi*jpk,jpj*jpk) )
20   INTEGER, PARAMETER :: num_2d_wrkspaces  = 35 ! No. of 2D workspace arrays (jpi,jpj)
21   INTEGER, PARAMETER :: num_3d_wrkspaces  = 15 ! No. of 3D workspace arrays (jpi,jpj,jpk)
22   INTEGER, PARAMETER :: num_4d_wrkspaces  = 4 ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts)
23
24   INTEGER, PARAMETER :: num_xz_wrkspaces  = 4 ! No. of 2D, xz workspace arrays (jpi,jpk)
25
26   INTEGER, PARAMETER :: num_1d_lwrkspaces = 0 ! No. of 1D logical workspace arrays
27   INTEGER, PARAMETER :: num_2d_lwrkspaces = 3 ! No. of 2D logical workspace arrays
28   INTEGER, PARAMETER :: num_3d_lwrkspaces = 1 ! No. of 3D logical workspace arrays
29   INTEGER, PARAMETER :: num_4d_lwrkspaces = 0 ! No. of 4D logical workspace arrays
30
31   INTEGER, PARAMETER :: num_1d_iwrkspaces = 0 ! No. of 1D integer workspace arrays
32   INTEGER, PARAMETER :: num_2d_iwrkspaces = 1 ! No. of 2D integer workspace arrays
33   INTEGER, PARAMETER :: num_3d_iwrkspaces = 0 ! No. of 3D integer workspace arrays
34   INTEGER, PARAMETER :: num_4d_iwrkspaces = 0 ! No. of 4D integer workspace arrays
35   ! Maximum no. of workspaces of any one dimensionality that can be
36   ! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces,
37   ! num_4d_wrkspaces)
38   INTEGER, PARAMETER :: max_num_wrkspaces = 35
39
40   ! If adding more arrays here, remember to increment the appropriate
41   ! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc()
42
43   ! 1D, REAL(wp) workspaces
44   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_1,  wrk_1d_2
45   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_3,  wrk_1d_4
46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_5,  wrk_1d_6 
47   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_7,  wrk_1d_8
48   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_9,  wrk_1d_10
49   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_11, wrk_1d_12
50   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_13, wrk_1d_14
51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_15, wrk_1d_16
52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_17, wrk_1d_18
53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_19, wrk_1d_20
54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_21, wrk_1d_22
55   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_23, wrk_1d_24
56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_25, wrk_1d_26
57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:), TARGET, PUBLIC :: wrk_1d_27
58
59   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_1 !: 2D real workspace
60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_2 !: 2D real workspace
61   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_3 !: 2D real workspace
62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_4 !: 2D real workspace
63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_5 !: 2D real workspace
64   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_6 !: 2D real workspace
65   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_7 !: 2D real workspace
66   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_8 !: 2D real workspace
67   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_9 !: 2D real workspace
68   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_10 !: 2D real workspace
69   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_11 !: 2D real workspace
70   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_12 !: 2D real workspace
71   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_13 !: 2D real workspace
72   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_14 !: 2D real workspace
73   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_15 !: 2D real workspace
74   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_16 !: 2D real workspace
75   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_17 !: 2D real workspace
76   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_18 !: 2D real workspace
77   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_19 !: 2D real workspace
78   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_20 !: 2D real workspace
79   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_21 !: 2D real workspace
80   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_22 !: 2D real workspace
81   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_23 !: 2D real workspace
82   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_24 !: 2D real workspace
83   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_25 !: 2D real workspace
84   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_26 !: 2D real workspace
85   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_27 !: 2D real workspace
86   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_28 !: 2D real workspace
87   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_29 !: 2D real workspace
88   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_30 !: 2D real workspace
89   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_31 !: 2D real workspace
90   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_32 !: 2D real workspace
91   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_33 !: 2D real workspace
92   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_34 !: 2D real workspace
93   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET, PUBLIC :: wrk_2d_35 !: 2D real workspace
94
95   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_1   !: 3D real workspace
96   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_2   !: 3D real workspace
97   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_3   !: 3D real workspace
98   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_4   !: 3D real workspace
99   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_5   !: 3D real workspace
100   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_6   !: 3D real workspace
101   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_7   !: 3D real workspace
102   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_8   !: 3D real workspace
103   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_9   !: 3D real workspace
104   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_10  !: 3D real workspace
105   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_11  !: 3D real workspace
106   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_12  !: 3D real workspace
107   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_13  !: 3D real workspace
108   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_14  !: 3D real workspace
109   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC ::  wrk_3d_15  !: 3D real workspace
110
111   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:), PUBLIC :: wrk_4d_1, wrk_4d_2, wrk_4d_3, wrk_4d_4   !: 4D real workspace
112
113   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: wrk_xz_1, wrk_xz_2, wrk_xz_3, wrk_xz_4 !: 2D, x-z workspaces
114
115   LOGICAL,  ALLOCATABLE, SAVE, DIMENSION(:,:)    , PUBLIC :: llwrk_2d_1, llwrk_2d_2, llwrk_2d_3 !: 2D logical workspace
116   LOGICAL,  ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET, PUBLIC :: llwrk_3d_1 !: 3D logical workspace
117
118   INTEGER,  ALLOCATABLE, SAVE, DIMENSION(:,:)    , PUBLIC :: iwrk_2d_1 !: 2D integer workspace
119
120
121   LOGICAL, DIMENSION(num_1d_wrkspaces)  :: in_use_1d   !: Flags to track which 1D workspace arrays are in use 
122   LOGICAL, DIMENSION(num_2d_wrkspaces)  :: in_use_2d   !: Flags to track which 2D workspace arrays are in use
123   LOGICAL, DIMENSION(num_3d_wrkspaces)  :: in_use_3d   !: Flags to track which 3D workspace arrays are in use
124   LOGICAL, DIMENSION(num_4d_wrkspaces)  :: in_use_4d   !: Flags to track which 4D workspace arrays are in use
125   LOGICAL, DIMENSION(num_xz_wrkspaces)  :: in_use_xz   !: Flags to track which 2D, xz workspace arrays are in use
126   LOGICAL, DIMENSION(num_2d_lwrkspaces) :: in_use_2dll !: Flags to track which 2D, logical workspace arrays are in use
127   LOGICAL, DIMENSION(num_3d_lwrkspaces) :: in_use_3dll !: Flags to track which 3D, logical workspace arrays are in use
128   LOGICAL, DIMENSION(num_2d_iwrkspaces) :: in_use_2di  !: Flags to track which 2D, integer workspace arrays are in use
129
130   ! Labels for specifying workspace type in call to print_in_use_list()
131   INTEGER, PARAMETER :: INTEGER_TYPE = 0
132   INTEGER, PARAMETER :: LOGICAL_TYPE = 1
133   INTEGER, PARAMETER :: REAL_TYPE    = 2
134
135   !!----------------------------------------------------------------------
136   !! NEMO/OPA 4.0 , NEMO Consortium (2010)
137   !! $Id$
138   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
139   !!----------------------------------------------------------------------
140CONTAINS
141
142
143  FUNCTION wrk_alloc()
144      !!----------------------------------------------------------------------
145      !!                   ***  ROUTINE wrk_alloc  ***
146      !!
147      !! ** Purpose :   Define in memory once for all the NEMO 2D, 3D and 4d
148      !!                work space arrays
149      !!----------------------------------------------------------------------
150      INTEGER :: wrk_alloc     ! Return value
151      INTEGER :: extent_1d     ! Extent to allocate for 1D arrays
152      INTEGER :: ierror(8)     ! local integer
153      !!----------------------------------------------------------------------
154      !
155      ! Extent to use for 1D work arrays - find the maximum product of
156      ! jpi*jpj, jpi*jpk and jpj*jpk and use that
157      IF(jpi < jpj .AND. jpi < jpk)THEN
158         extent_1d = jpj*jpk
159      ELSE IF(jpj < jpi .AND. jpj < jpk)THEN
160         extent_1d = jpi*jpk
161      ELSE
162         extent_1d = jpi*jpj
163      END IF
164      !
165      ! Initialise the 'in use' flags for each work-space array
166      in_use_1d(:) = .FALSE.
167
168      in_use_2d(:) = .FALSE.
169
170      in_use_3d(:) = .FALSE.
171
172      in_use_4d(:) = .FALSE.
173
174      in_use_xz(:) = .FALSE.
175
176      in_use_2dll(:) = .FALSE.
177
178      in_use_3dll(:) = .FALSE.
179
180      in_use_2di(:) = .FALSE.
181
182      ierror(:) = 0
183
184      ALLOCATE(wrk_1d_1(extent_1d)        , wrk_1d_2(extent_1d)       ,  &
185               wrk_1d_3(extent_1d)        , wrk_1d_4(extent_1d)       ,  &
186               wrk_1d_5(extent_1d)        , wrk_1d_6(extent_1d)       ,  &
187               wrk_1d_7(extent_1d)        , wrk_1d_8(extent_1d)       ,  &
188               wrk_1d_9(extent_1d)        , wrk_1d_10(extent_1d)      ,  &
189               wrk_1d_11(extent_1d)       , wrk_1d_12(extent_1d)      ,  &
190               wrk_1d_13(extent_1d)       , wrk_1d_14(extent_1d)      ,  &
191               wrk_1d_15(extent_1d)       , wrk_1d_16(extent_1d)      ,  &
192               wrk_1d_17(extent_1d)       , wrk_1d_18(extent_1d)      ,  &
193               wrk_1d_19(extent_1d)       , wrk_1d_20(extent_1d)      ,  &
194               wrk_1d_21(extent_1d)       , wrk_1d_22(extent_1d)      ,  &
195               wrk_1d_23(extent_1d)       , wrk_1d_24(extent_1d)      ,  &
196               wrk_1d_25(extent_1d)       , wrk_1d_26(extent_1d)      ,  &
197               wrk_1d_27(extent_1d)       , Stat=ierror(1))
198      !
199      ALLOCATE(wrk_2d_1(jpi,jpj)          , wrk_2d_2(jpi,jpj)         ,  &
200               wrk_2d_3(jpi,jpj)          , wrk_2d_4(jpi,jpj)         ,  & 
201               wrk_2d_5(jpi,jpj)          , wrk_2d_6(jpi,jpj)         ,  &
202               wrk_2d_7(jpi,jpj)          , wrk_2d_8(jpi,jpj)         ,  &
203               wrk_2d_9(jpi,jpj)          , wrk_2d_10(jpi,jpj)        ,  &
204               wrk_2d_11(jpi,jpj)         , wrk_2d_12(jpi,jpj)        ,  &
205               wrk_2d_13(jpi,jpj)         , wrk_2d_14(jpi,jpj)        ,  &
206               wrk_2d_15(jpi,jpj)         , wrk_2d_16(jpi,jpj)        ,  &
207               wrk_2d_17(jpi,jpj)         , wrk_2d_18(jpi,jpj)        ,  &
208               wrk_2d_19(jpi,jpj)         , wrk_2d_20(jpi,jpj)        ,  &
209               wrk_2d_21(jpi,jpj)         , wrk_2d_22(jpi,jpj)        ,  &
210               wrk_2d_23(jpi,jpj)         , wrk_2d_24(jpi,jpj)        ,  &
211               wrk_2d_25(jpi,jpj)         , wrk_2d_26(jpi,jpj)        ,  &
212               wrk_2d_27(jpi,jpj)         , wrk_2d_28(jpi,jpj)        ,  &
213               wrk_2d_29(jpi,jpj)         , wrk_2d_30(jpi,jpj)        ,  &
214               wrk_2d_31(jpi,jpj)         , wrk_2d_32(jpi,jpj)        ,  &
215               wrk_2d_33(jpi,jpj)         , wrk_2d_34(jpi,jpj)        ,  &
216               wrk_2d_35(jpi,jpj)         , Stat=ierror(2))
217      !
218      ALLOCATE(wrk_3d_1(jpi,jpj,jpk)      , wrk_3d_2(jpi,jpj,jpk)     ,  &
219               wrk_3d_3(jpi,jpj,jpk)      , wrk_3d_4(jpi,jpj,jpk)     ,  &
220               wrk_3d_5(jpi,jpj,jpk)      , wrk_3d_6(jpi,jpj,jpk)     ,  &
221               wrk_3d_7(jpi,jpj,jpk)      , wrk_3d_8(jpi,jpj,jpk)     ,  &
222               wrk_3d_9(jpi,jpj,jpk)      , wrk_3d_10(jpi,jpj,jpk)    ,  & 
223               wrk_3d_11(jpi,jpj,jpk)     , wrk_3d_12(jpi,jpj,jpk)    ,  & 
224               wrk_3d_13(jpi,jpj,jpk)     , wrk_3d_14(jpi,jpj,jpk)    ,  & 
225               wrk_3d_15(jpi,jpj,jpk)     , Stat=ierror(3))
226      !
227      ALLOCATE(wrk_4d_1(jpi,jpj,jpk,jpts) , wrk_4d_2(jpi,jpj,jpk,jpts),  &
228               wrk_4d_3(jpi,jpj,jpk,jpts) , wrk_4d_4(jpi,jpj,jpk,jpts),  &
229               Stat=ierror(4) )
230      !
231      ALLOCATE(wrk_xz_1(jpi,jpk)          , wrk_xz_2(jpi,jpk),           &
232               wrk_xz_3(jpi,jpk)          , wrk_xz_4(jpi,jpk),           &
233               Stat=ierror(5))
234      !
235      ALLOCATE(llwrk_2d_1(jpi,jpj)        , llwrk_2d_2(jpi,jpj),         &
236               llwrk_2d_3(jpi,jpj)        , Stat=ierror(6))
237      !
238      ALLOCATE(llwrk_3d_1(jpi,jpj,jpk)    , Stat=ierror(7))
239      !
240      ALLOCATE(iwrk_2d_1(jpi,jpj)         , Stat=ierror(8))
241      !
242      wrk_alloc = MAXVAL(ierror)
243
244      ! Calling routine, nemo_alloc(), checks for errors and takes
245      ! appropriate action - we just print a warning message
246      IF(wrk_alloc /= 0)THEN
247         CALL ctl_warn('wrk_alloc: allocation of workspace arrays failed')
248      END IF
249
250   END FUNCTION wrk_alloc
251
252
253   FUNCTION wrk_use(ndim,    index1,  index2,  index3,  index4,  &
254                    index5,  index6,  index7,  index8,  index9,  &
255                    index10, index11, index12, index13, index14, &
256                    index15, index16, index17, index18, index19, &
257                    index20, index21, index22, index23, index24, &
258                    index25, index26, index27)
259      !!----------------------------------------------------------------------
260      !!                   ***  ROUTINE wrk_use  ***
261      !!
262      !! ** Purpose :   Request a set of KIND(wp) workspaces to use. Returns
263      !!                .TRUE. if all those requested are available, .FALSE.
264      !!                otherwise.
265      !!
266      !! ** Method  :   Sets
267      !!                internal flags to signal that requested workspaces
268      !!                are in use.
269      !!----------------------------------------------------------------------
270      IMPLICIT none
271      LOGICAL             :: wrk_use     ! Return value
272      INTEGER, INTENT(in) :: ndim        ! Dimensionality of requested workspace(s)
273      INTEGER, INTENT(in) :: index1      ! Index of first requested workspace
274      INTEGER, OPTIONAL, INTENT(in) :: index2, index3,   index4,  index5,  &
275                                       index6, index7,   index8,  index9,  &
276                                       index10, index11, index12, index13, &
277                                       index14, index15, index16, index17, &
278                                       index18, index19, index20, index21, &
279                                       index22, index23, index24, index25, &
280                                       index26, index27
281      ! Local variables
282      INTEGER :: iarg, iptr
283      !!----------------------------------------------------------------------
284
285      wrk_use = .TRUE.
286
287      iptr = index1
288      iarg = 1
289      DO WHILE(wrk_use .AND. iarg <= max_num_wrkspaces)
290
291         IF(ndim == 1)THEN
292
293            IF(iptr > num_1d_wrkspaces)THEN
294               CALL ctl_stop('wrk_use - more 1D workspace arrays requested than defined in wrk_nemo module')
295               wrk_use = .FALSE.
296               EXIT
297            ELSE IF( in_use_1d(iptr) )THEN
298               wrk_use = .FALSE.
299               CALL print_in_use_list(1, REAL_TYPE, in_use_1d)
300            END IF
301
302            in_use_1d(iptr) = .TRUE.
303
304         ELSE IF(ndim == 2)THEN
305
306            IF(iptr > num_2d_wrkspaces)THEN
307               CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')
308               wrk_use = .FALSE.
309               EXIT
310            ELSE IF( in_use_2d(iptr) )THEN
311               wrk_use = .FALSE.
312               CALL print_in_use_list(2, REAL_TYPE, in_use_2d)
313            END IF
314
315            in_use_2d(iptr) = .TRUE.
316
317         ELSE IF (ndim == 3)THEN
318
319            IF(iptr > num_3d_wrkspaces)THEN
320               CALL ctl_stop('wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module')
321               wrk_use = .FALSE.
322               EXIT
323            ELSE IF( in_use_3d(iptr) )THEN
324               wrk_use = .FALSE.
325               CALL print_in_use_list(3, REAL_TYPE, in_use_3d)
326            END IF
327
328            in_use_3d(iptr) = .TRUE.
329
330         ELSE IF (ndim == 4) THEN
331
332            IF(iptr > num_4d_wrkspaces)THEN
333               CALL ctl_stop('wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module')
334               wrk_use = .FALSE.
335               EXIT
336            ELSE IF( in_use_4d(iptr) )THEN
337               wrk_use = .FALSE.
338               CALL print_in_use_list(4, REAL_TYPE, in_use_4d)
339            END IF
340
341            in_use_4d(iptr) = .TRUE.
342
343         ELSE
344            IF(lwp) WRITE(numout,*) 'wrk_use: unsupported value of ndim = ',ndim
345            CALL ctl_stop('wrk_use: unrecognised value for number of dimensions')
346         END IF
347
348         CALL get_next_arg(iarg  ,  iptr  ,  index2,  index3,  index4,  &
349                           index5,  index6,  index7,  index8,  index9,  &
350                           index10, index11, index12, index13, index14, &
351                           index15, index16, index17, index18, index19, &
352                           index20, index21, index22, index23, index24, &
353                           index25, index26, index27)
354
355         IF(iarg == -1)THEN
356            ! We've checked all of the arguments and are done
357            EXIT
358         ELSE IF(iarg == -99)THEN
359            CALL ctl_stop('wrk_use - ERROR, caught unexpected argument count - BUG')
360            EXIT
361         END IF
362
363      END DO ! end of DO WHILE()
364
365    END FUNCTION wrk_use
366
367
368    FUNCTION llwrk_use(ndim,   index1, index2, index3, index4, &
369                       index5, index6, index7, index8, index9)
370      !!----------------------------------------------------------------------
371      !!                   ***  ROUTINE llwrk_use  ***
372      !!
373      !! ** Purpose :   Request a set of LOGICAL workspaces to use. Returns
374      !!                .TRUE. if all those requested are available, .FALSE.
375      !!                otherwise.
376      !!
377      !! ** Method  :   Sets
378      !!                internal flags to signal that requested workspaces
379      !!                are in use.
380      !!----------------------------------------------------------------------
381      LOGICAL             :: llwrk_use     ! Return value
382      INTEGER, INTENT(in) :: ndim        ! Dimensionality of requested workspace(s)
383      INTEGER, INTENT(in) :: index1      ! Index of first requested workspace
384      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
385                                       index6, index7, index8, index9
386      ! Local variables
387      INTEGER :: iarg, iptr
388      !!----------------------------------------------------------------------
389
390      llwrk_use = .TRUE.
391
392      iptr = index1
393      iarg = 1
394      DO WHILE(llwrk_use .AND. iarg <= max_num_wrkspaces)
395
396         IF(ndim == 2)THEN
397
398            IF(iptr > num_2d_lwrkspaces)THEN
399               CALL ctl_stop('llwrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')
400               llwrk_use = .FALSE.
401               EXIT
402            ELSE IF( in_use_2dll(iptr) )THEN
403               llwrk_use = .FALSE.
404               CALL print_in_use_list(2, REAL_TYPE, in_use_2d)
405            END IF
406
407            in_use_2dll(iptr) = .TRUE.
408
409         ELSE IF (ndim == 3)THEN
410
411            IF(iptr > num_3d_lwrkspaces)THEN
412               CALL ctl_stop('llwrk_use - more 3D workspace arrays requested than defined in wrk_nemo module')
413               llwrk_use = .FALSE.
414               EXIT
415            ELSE IF( in_use_3dll(iptr) )THEN
416               llwrk_use = .FALSE.
417               CALL print_in_use_list(3, REAL_TYPE, in_use_3d)
418            END IF
419
420            in_use_3dll(iptr) = .TRUE.
421         ELSE
422            IF(lwp) WRITE(numout,*) 'llwrk_use: unsupported value of ndim = ',ndim
423            CALL ctl_stop('llwrk_use: unrecognised value for number of dimensions')
424         END IF
425
426         CALL get_next_arg(iarg  , iptr  , index2, index3, index4, &
427                           index5, index6, index7, index8, index9)
428
429         IF(iarg == -1)THEN
430            ! We've checked all of the arguments and are done
431            EXIT
432         ELSE IF(iarg == -99)THEN
433            CALL ctl_stop('llwrk_use - ERROR, caught unexpected argument count - BUG')
434            EXIT
435         END IF
436
437      END DO ! while(llwrk_use .AND. iarg <= max_num_wrkspaces)
438
439    END FUNCTION llwrk_use
440
441
442    FUNCTION iwrk_use(ndim,   index1, index2, index3, index4, &
443                      index5, index6, index7)
444      !!----------------------------------------------------------------------
445      !!                   ***  ROUTINE iwrk_use  ***
446      !!
447      !! ** Purpose :   Request a set of INTEGER workspaces to use. Returns
448      !!                .TRUE. if all those requested are available, .FALSE.
449      !!                otherwise.
450      !!
451      !! ** Method  :   Sets
452      !!                internal flags to signal that requested workspaces
453      !!                are in use.
454      !!----------------------------------------------------------------------
455      LOGICAL             :: iwrk_use    ! Return value
456      INTEGER, INTENT(in) :: ndim        ! Dimensionality of requested workspace(s)
457      INTEGER, INTENT(in) :: index1      ! Index of first requested workspace
458      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
459                                       index6, index7
460      ! Local variables
461      INTEGER :: iarg, iptr
462      !!----------------------------------------------------------------------
463
464      iwrk_use = .TRUE.
465
466      iptr = index1
467      iarg = 1
468      DO WHILE(iwrk_use .AND. iarg <= max_num_wrkspaces)
469
470         IF(ndim == 2)THEN
471
472            IF(iptr > num_2d_wrkspaces)THEN
473               CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')
474               iwrk_use = .FALSE.
475            ELSE IF( in_use_2di(iptr) )THEN
476               iwrk_use = .FALSE.
477               CALL print_in_use_list(2, INTEGER_TYPE, in_use_2di)
478            END IF
479
480            in_use_2di(iptr) = .TRUE.
481
482         ELSE
483            IF(lwp) WRITE(numout,*) 'iwrk_use: unsupported value of ndim = ',ndim
484            CALL ctl_stop('iwrk_use: unsupported value for number of dimensions')
485         END IF
486
487         ! Move on to next optional argument
488         SELECT CASE (iarg)
489         CASE ( 1 )
490            IF(.not. PRESENT(index2))THEN
491               EXIT
492            ELSE
493               iarg = 2
494               iptr = index2
495            END IF
496         CASE ( 2 )
497            IF(.not. PRESENT(index3))THEN
498               EXIT
499            ELSE
500               iarg = 3
501               iptr = index3
502            END IF
503         CASE ( 3 )
504            IF(.not. PRESENT(index4))THEN
505               EXIT
506            ELSE
507               iarg = 4
508               iptr = index4
509            END IF
510         CASE ( 4 )
511            IF(.not. PRESENT(index5))THEN
512               EXIT
513            ELSE
514               iarg = 5
515               iptr = index5
516            END IF
517         CASE ( 5 )
518            IF(.not. PRESENT(index6))THEN
519               EXIT
520            ELSE
521               iarg = 6
522               iptr = index6
523            END IF
524         CASE ( 6 )
525            IF(.not. PRESENT(index7))THEN
526               EXIT
527            ELSE
528               iarg = 7
529               iptr = index7
530            END IF
531         CASE ( 7 )
532            EXIT
533         CASE DEFAULT
534            CALL ctl_stop('iwrk_use - ERROR, caught unexpected argument count - BUG')
535            EXIT
536         END SELECT
537
538      END DO ! end of DO WHILE()
539
540    END FUNCTION iwrk_use
541
542
543    FUNCTION wrk_use_xz(index1, index2, index3, index4, &
544                        index5, index6, index7, index8, index9)
545      !!----------------------------------------------------------------------
546      !!                   ***  ROUTINE wrk_use_xz  ***
547      !!
548      !! ** Purpose :   Request a set of 2D, xz (jpi,jpk) workspaces to use.
549      !!                Returns .TRUE. if all those requested are available,
550      !!                .FALSE. otherwise.
551      !!
552      !! ** Method  :   Sets
553      !!                internal flags to signal that requested workspaces
554      !!                are in use.
555      !!----------------------------------------------------------------------
556      LOGICAL             :: wrk_use_xz     ! Return value
557      INTEGER, INTENT(in) :: index1      ! Index of first requested workspace
558      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
559                                       index6, index7, index8, index9
560      ! Local variables
561      INTEGER :: iarg, iptr
562      !!----------------------------------------------------------------------
563
564      wrk_use_xz = .TRUE.
565
566      iptr = index1
567      iarg = 1
568      DO WHILE(wrk_use_xz .AND. iarg <= max_num_wrkspaces)
569
570            IF(iptr > num_xz_wrkspaces)THEN
571               CALL ctl_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module')
572               wrk_use_xz = .FALSE.
573               EXIT
574            ELSE IF( in_use_xz(iptr) )THEN
575               wrk_use_xz = .FALSE.
576               CALL print_in_use_list(2, REAL_TYPE, in_use_xz) !ARPDBG - bug
577            END IF
578
579            in_use_xz(iptr) = .TRUE.
580
581         CALL get_next_arg(iarg  , iptr  , index2, index3, index4, &
582                           index5, index6, index7, index8, index9)
583
584         IF(iarg == -1)THEN
585            ! We've checked all of the arguments and are done
586            EXIT
587         ELSE IF(iarg == -99)THEN
588            CALL ctl_stop('wrk_use_xz - ERROR, caught unexpected argument count - BUG')
589            EXIT
590         END IF
591
592      END DO ! while(wrk_use_xz .AND. iarg <= max_num_wrkspaces)
593
594    END FUNCTION wrk_use_xz
595
596
597    FUNCTION wrk_release(ndim,    index1,  index2,  index3,  index4,  &
598                         index5,  index6,  index7,  index8,  index9,  &
599                         index10, index11, index12, index13, index14, &
600                         index15, index16, index17, index18, index19, &
601                         index20, index21, index22, index23, index24, &
602                         index25, index26, index27)
603       !!----------------------------------------------------------------------
604       !!                 ***  ROUTINE wrk_release  ***
605       !!
606       !! ** Purpose :   Flag that the specified workspace arrays are no-longer
607       !!                in use.
608       !!----------------------------------------------------------------------
609       LOGICAL             :: wrk_release ! Return value
610       INTEGER, INTENT(in) :: ndim             ! Dimensionality of workspace(s)
611       INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
612       INTEGER, OPTIONAL, INTENT(in) :: index2,  index3,  index4,  index5,  &
613                                        index6,  index7,  index8,  index9,  &
614                                        index10, index11, index12, index13, &
615                                        index14, index15, index16, index17, &
616                                        index18, index19, index20, index21, &
617                                        index22, index23, index24, index25, &
618                                        index26, index27
619       ! Local variables
620       INTEGER :: iarg, iptr
621       !!----------------------------------------------------------------------
622
623       wrk_release = .TRUE.
624       iptr = index1
625       iarg = 1
626
627       DO WHILE(iarg <= max_num_wrkspaces)
628
629          IF(ndim == 1)THEN
630
631             IF(iptr > num_1d_wrkspaces)THEN
632                CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 1D workspace array')
633                wrk_release = .FALSE.
634             ELSE
635                in_use_1d(iptr) = .FALSE.
636             END IF
637
638          ELSE IF(ndim == 2)THEN
639
640             IF(iptr > num_2d_wrkspaces)THEN
641                CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 2D workspace array')
642                wrk_release = .FALSE.
643             END IF
644
645             in_use_2d(iptr) = .FALSE.
646
647          ELSE IF (ndim == 3)THEN
648
649             IF(iptr > num_3d_wrkspaces)THEN
650                CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 3D workspace array')
651                wrk_release = .FALSE.
652             END IF
653
654             in_use_3d(iptr) = .FALSE.
655
656          ELSE IF (ndim == 4) THEN
657
658             IF(iptr > num_4d_wrkspaces)THEN
659                CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 4D workspace array')
660                wrk_release = .FALSE.
661             END IF
662
663             in_use_4d(iptr) = .FALSE.
664
665          ELSE
666             IF(lwp) WRITE(numout,*) 'wrk_release: unsupported value of ndim = ',ndim
667             CALL ctl_stop('wrk_release: unrecognised value for number of dimensions')
668          END IF
669
670          ! Move on to next optional argument
671          CALL get_next_arg(iarg  ,  iptr  ,  index2,  index3,  index4, &
672                            index5,  index6,  index7,  index8,  index9, &
673                            index10, index11, index12, index13,         &
674                            index14, index15, index16, index17,         &
675                            index18, index19, index20, index21,         &
676                            index22, index23, index24, index25,         &
677                            index26, index27)
678
679          IF(iarg == -1)THEN
680             ! We've checked all of the arguments and are done
681             EXIT
682          ELSE IF(iarg == -99)THEN
683             CALL ctl_stop('wrk_release - caught unexpected argument count - BUG')
684             EXIT
685          END IF
686
687      END DO ! end of DO WHILE()
688
689    END FUNCTION wrk_release
690
691
692    FUNCTION llwrk_release(ndim,   index1, index2, index3, index4, index5, &
693                           index6, index7, index8, index9)
694       LOGICAL             :: llwrk_release ! Return value
695       INTEGER, INTENT(in) :: ndim             ! Dimensionality of workspace(s)
696       INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
697       INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
698                                        index6, index7, index8, index9
699       ! Local variables
700       INTEGER :: iarg, iptr
701       !!----------------------------------------------------------------------
702
703       llwrk_release = .TRUE.
704       iptr = index1
705       iarg = 1
706
707       DO WHILE(iarg <= max_num_wrkspaces)
708
709          IF(ndim == 2)THEN
710
711             IF(iptr > num_2d_lwrkspaces)THEN
712                CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 2D workspace array')
713                llwrk_release = .FALSE.
714                EXIT
715             END IF
716
717             in_use_2dll(iptr) = .FALSE.
718
719          ELSE IF (ndim == 3)THEN
720
721             IF(iptr > num_3d_lwrkspaces)THEN
722                CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 3D workspace array')
723                llwrk_release = .FALSE.
724                EXIT
725             END IF
726
727             in_use_3dll(iptr) = .FALSE.
728
729          ELSE
730             IF(lwp) WRITE(numout,*) 'llwrk_release: unsupported value of ndim = ',ndim
731             CALL ctl_stop('llwrk_release: unrecognised value for number of dimensions')
732          END IF
733
734          ! Move on to next optional argument
735          CALL get_next_arg(iarg  , iptr  , index2, index3, index4, &
736                            index5, index6, index7, index8, index9)
737
738          IF(iarg == -1)THEN
739             ! We've checked all of the arguments and are done
740             EXIT
741          ELSE IF(iarg == -99)THEN
742             CALL ctl_stop('llwrk_release - ERROR, caught unexpected argument count - BUG')
743             EXIT
744          END IF
745
746       END DO ! while (iarg <= max_num_wrkspaces)
747
748    END FUNCTION llwrk_release
749
750
751    FUNCTION iwrk_release(ndim, index1, index2, index3, index4, index5, &
752                           index6, index7)
753       !!----------------------------------------------------------------------
754       !!                 ***  ROUTINE iwrk_release  ***
755       !!
756       !! ** Purpose :   Flag that the specified INTEGER workspace arrays are
757       !!                no-longer in use.
758       !!----------------------------------------------------------------------
759       LOGICAL             :: iwrk_release     ! Return value
760       INTEGER, INTENT(in) :: ndim             ! Dimensionality of workspace(s)
761       INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
762       INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
763                                        index6, index7
764       ! Local variables
765       INTEGER :: iarg, iptr
766       !!----------------------------------------------------------------------
767
768       iwrk_release = .TRUE.
769       iptr = index1
770       iarg = 1
771
772       DO WHILE(iarg <= max_num_wrkspaces)
773
774          IF(ndim == 2)THEN
775
776             IF(iptr > num_2d_iwrkspaces)THEN
777                CALL ctl_stop('iwrk_release - ERROR - attempt to release a non-existant 2D workspace array')
778                iwrk_release = .FALSE.
779             END IF
780
781             in_use_2di(iptr) = .FALSE.
782          ELSE
783             IF(lwp) WRITE(numout,*) 'iwrk_release: unsupported value of ndim = ',ndim
784             CALL ctl_stop('iwrk_release: unsupported value for number of dimensions')
785          END IF
786
787          ! Move on to next optional argument
788          SELECT CASE (iarg)
789          CASE ( 1 )
790             IF(.not. PRESENT(index2))THEN
791                EXIT
792             ELSE
793                iarg = 2
794                iptr = index2
795             END IF
796          CASE ( 2 )
797             IF(.not. PRESENT(index3))THEN
798                EXIT
799             ELSE
800                iarg = 3
801                iptr = index3
802             END IF
803          CASE ( 3 )
804             IF(.not. PRESENT(index4))THEN
805                EXIT
806             ELSE
807                iarg = 4
808                iptr = index4
809             END IF
810          CASE ( 4 )
811             IF(.not. PRESENT(index5))THEN
812                EXIT
813             ELSE
814                iarg = 5
815                iptr = index5
816             END IF
817          CASE ( 5 )
818             IF(.not. PRESENT(index6))THEN
819                EXIT
820             ELSE
821                iarg = 6
822                iptr = index6
823             END IF
824          CASE ( 6 )
825             IF(.not. PRESENT(index7))THEN
826                EXIT
827             ELSE
828                iarg = 7
829                iptr = index7
830             END IF
831          CASE ( 7 )
832             EXIT
833          CASE DEFAULT
834             CALL ctl_stop('iwrk_release - ERROR, caught unexpected argument count - BUG')
835             EXIT
836          END SELECT
837
838       END DO ! end of DO WHILE()
839
840    END FUNCTION iwrk_release
841
842
843    FUNCTION wrk_release_xz(index1, index2, index3, index4, index5, &
844                            index6, index7, index8, index9)
845       LOGICAL             :: wrk_release_xz   ! Return value
846       INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
847       INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, &
848                                        index6, index7, index8, index9
849       ! Local variables
850       INTEGER :: iarg, iptr
851       !!----------------------------------------------------------------------
852
853       wrk_release_xz = .TRUE.
854       iptr = index1
855       iarg = 1
856
857       DO WHILE(iarg <= max_num_wrkspaces)
858
859             IF(iptr > num_xz_wrkspaces)THEN
860                CALL ctl_stop('wrk_release_xz - ERROR - attempt to release a non-existant 2D xz workspace array')
861                wrk_release_xz = .FALSE.
862                EXIT
863             END IF
864
865             in_use_xz(iptr) = .FALSE.
866
867
868          ! Move on to next optional argument
869          CALL get_next_arg(iarg  , iptr  , index2, index3, index4, &
870                            index5, index6, index7, index8, index9)
871
872          IF(iarg == -1)THEN
873             ! We've checked all of the arguments and are done
874             EXIT
875          ELSE IF(iarg == -99)THEN
876             CALL ctl_stop('wrk_release_xz - ERROR, caught unexpected argument count - BUG')
877             EXIT
878          END IF
879
880       END DO ! while (iarg <= max_num_wrkspaces)
881
882    END FUNCTION wrk_release_xz
883
884
885    SUBROUTINE print_in_use_list(ndim, itype, in_use_list)
886       !!----------------------------------------------------------------------
887       !!                 *** routine print_in_use_list ***
888       !!
889       !!    Purpose: to print out the table holding which workspace arrays
890       !!             are currently marked as in use.
891       !!----------------------------------------------------------------------
892       IMPLICIT none
893       INTEGER,               INTENT(in) :: ndim
894       INTEGER,               INTENT(in) :: itype
895       LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list
896       ! Locals
897       INTEGER          :: ii, icount
898       CHARACTER(LEN=7) :: type_string
899       !!----------------------------------------------------------------------
900
901       IF(.NOT. lwp) RETURN
902
903       SELECT CASE (ndim)
904
905       CASE (1)
906
907          SELECT CASE (itype)
908
909          CASE (INTEGER_TYPE)
910             icount = num_1d_iwrkspaces
911          CASE (LOGICAL_TYPE)
912             icount = num_1d_lwrkspaces
913          CASE (REAL_TYPE)
914             icount = num_1d_wrkspaces
915          END SELECT
916
917       CASE (2)
918
919          SELECT CASE (itype)
920
921          CASE (INTEGER_TYPE)
922             icount = num_2d_iwrkspaces
923          CASE (LOGICAL_TYPE)
924             icount = num_2d_lwrkspaces
925          CASE (REAL_TYPE)
926             icount = num_2d_wrkspaces
927          END SELECT
928
929       CASE (3)
930
931          SELECT CASE (itype)
932
933          CASE (INTEGER_TYPE)
934             icount = num_3d_iwrkspaces
935          CASE (LOGICAL_TYPE)
936             icount = num_3d_lwrkspaces
937          CASE (REAL_TYPE)
938             icount = num_3d_wrkspaces
939          END SELECT
940
941       CASE (4)
942          SELECT CASE (itype)
943
944          CASE (INTEGER_TYPE)
945             icount = num_4d_iwrkspaces
946          CASE (LOGICAL_TYPE)
947             icount = num_4d_lwrkspaces
948          CASE (REAL_TYPE)
949             icount = num_4d_wrkspaces
950          END SELECT
951
952       CASE DEFAULT
953          RETURN
954
955       END SELECT
956
957       ! Set character string with type of workspace
958       SELECT CASE (itype)
959
960       CASE (INTEGER_TYPE)
961          type_string = "INTEGER" 
962       CASE (LOGICAL_TYPE)
963          type_string = "LOGICAL"
964       CASE (REAL_TYPE)
965          type_string = "REAL" 
966       END SELECT
967
968       WRITE(numout,*)
969       WRITE(numout,"('------------------------------------------')")
970       WRITE(numout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") ndim, TRIM(type_string)
971       WRITE(numout,"('Workspace   In use')")
972       DO ii=1,icount, 1
973          WRITE(numout,"(4x,I2,8x,L1)") ii, in_use_list(ii)
974       END DO
975       WRITE(numout,"('------------------------------------------')")
976       WRITE(numout,*)
977
978    END SUBROUTINE print_in_use_list
979
980
981    SUBROUTINE get_next_arg(iargidx, iargval, index2,  index3,  index4,  &
982                            index5 , index6,  index7,  index8,  index9,  &
983                            index10, index11, index12, index13, index14, &
984                            index15, index16, index17, index18, index19, &
985                            index20, index21, index22, index23, index24, &
986                            index25, index26, index27)
987       !!----------------------------------------------------------------------
988       INTEGER, INTENT(inout) :: iargidx ! Index of current arg
989       INTEGER, INTENT(inout) :: iargval ! Value of current arg
990       INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5,     &
991                                        index6, index7, index8, index9,     &
992                                        index10, index11, index12, index13, &
993                                        index14, index15, index16, index17, &
994                                        index18, index19, index20, index21, &
995                                        index22, index23, index24, index25, &
996                                        index26, index27
997       !!----------------------------------------------------------------------
998
999       ! Move on to next optional argument
1000       SELECT CASE (iargidx)
1001       CASE ( 1 )
1002          IF(.not. PRESENT(index2))THEN
1003             iargidx = -1
1004          ELSE
1005             iargidx = 2
1006             iargval = index2
1007          END IF
1008       CASE ( 2 )
1009          IF(.not. PRESENT(index3))THEN
1010             iargidx = -1
1011          ELSE
1012             iargidx = 3
1013             iargval = index3
1014          END IF
1015       CASE ( 3 )
1016          IF(.not. PRESENT(index4))THEN
1017             iargidx = -1
1018          ELSE
1019             iargidx = 4
1020             iargval = index4
1021          END IF
1022       CASE ( 4 )
1023          IF(.not. PRESENT(index5))THEN
1024             iargidx = -1
1025          ELSE
1026             iargidx = 5
1027             iargval = index5
1028          END IF
1029       CASE ( 5 )
1030          IF(.not. PRESENT(index6))THEN
1031             iargidx = -1
1032          ELSE
1033             iargidx = 6
1034             iargval = index6
1035          END IF
1036       CASE ( 6 )
1037          IF(.not. PRESENT(index7))THEN
1038             iargidx = -1
1039          ELSE
1040             iargidx = 7
1041             iargval = index7
1042          END IF
1043       CASE ( 7 )
1044          IF(.not. PRESENT(index8))THEN
1045             iargidx = -1
1046          ELSE
1047             iargidx = 8
1048             iargval = index8
1049          END IF
1050       CASE ( 8 )
1051          IF(.not. PRESENT(index9))THEN
1052             iargidx = -1
1053          ELSE
1054             iargidx = 9
1055             iargval = index9
1056          END IF
1057       CASE ( 9 )
1058          IF(.not. PRESENT(index10))THEN
1059             iargidx = -1
1060          ELSE
1061             iargidx = 10
1062             iargval = index10
1063          END IF
1064       CASE ( 10 )
1065          IF(.not. PRESENT(index11))THEN
1066             iargidx = -1
1067          ELSE
1068             iargidx = 11
1069             iargval = index11
1070          END IF
1071       CASE ( 11 )
1072          IF(.not. PRESENT(index12))THEN
1073             iargidx = -1
1074          ELSE
1075             iargidx = 12
1076             iargval = index12
1077          END IF
1078       CASE ( 12 )
1079          IF(.not. PRESENT(index13))THEN
1080             iargidx = -1
1081          ELSE
1082             iargidx = 13
1083             iargval = index13
1084          END IF
1085       CASE ( 13 )
1086          IF(.not. PRESENT(index14))THEN
1087             iargidx = -1
1088          ELSE
1089             iargidx = 14
1090             iargval = index14
1091          END IF
1092       CASE ( 14 )
1093          IF(.not. PRESENT(index15))THEN
1094             iargidx = -1
1095          ELSE
1096             iargidx = 15
1097             iargval = index15
1098          END IF
1099       CASE ( 15 )
1100          IF(.not. PRESENT(index16))THEN
1101             iargidx = -1
1102          ELSE
1103             iargidx = 16
1104             iargval = index16
1105          END IF
1106       CASE ( 16 )
1107          IF(.not. PRESENT(index17))THEN
1108             iargidx = -1
1109          ELSE
1110             iargidx = 17
1111             iargval = index17
1112          END IF
1113       CASE ( 17 )
1114          IF(.not. PRESENT(index18))THEN
1115             iargidx = -1
1116          ELSE
1117             iargidx = 18
1118             iargval = index18
1119          END IF
1120       CASE ( 18 )
1121          IF(.not. PRESENT(index19))THEN
1122             iargidx = -1
1123          ELSE
1124             iargidx = 19
1125             iargval = index19
1126          END IF
1127       CASE ( 19 )
1128          IF(.not. PRESENT(index20))THEN
1129             iargidx = -1
1130          ELSE
1131             iargidx = 20
1132             iargval = index20
1133          END IF
1134       CASE ( 20 )
1135          IF(.not. PRESENT(index21))THEN
1136             iargidx = -1
1137          ELSE
1138             iargidx = 21
1139             iargval = index21
1140          END IF
1141       CASE ( 21 )
1142          IF(.not. PRESENT(index22))THEN
1143             iargidx = -1
1144          ELSE
1145             iargidx = 22
1146             iargval = index22
1147          END IF
1148       CASE ( 22 )
1149          IF(.not. PRESENT(index23))THEN
1150             iargidx = -1
1151          ELSE
1152             iargidx = 23
1153             iargval = index23
1154          END IF
1155       CASE ( 23 )
1156          IF(.not. PRESENT(index24))THEN
1157             iargidx = -1
1158          ELSE
1159             iargidx = 24
1160             iargval = index24
1161          END IF
1162       CASE ( 24 )
1163          IF(.not. PRESENT(index25))THEN
1164             iargidx = -1
1165          ELSE
1166             iargidx = 25
1167             iargval = index25
1168          END IF
1169       CASE ( 25 )
1170          IF(.not. PRESENT(index26))THEN
1171             iargidx = -1
1172          ELSE
1173             iargidx = 26
1174             iargval = index26
1175          END IF
1176       CASE ( 26 )
1177          IF(.not. PRESENT(index27))THEN
1178             iargidx = -1
1179          ELSE
1180             iargidx = 27
1181             iargval = index27
1182          END IF
1183       CASE ( 27 )
1184          iargidx = -1
1185       CASE DEFAULT
1186          ! BUG - iargidx shouldn't take any other values!
1187          ! Flag error for calling routine
1188          iargidx = -99
1189       END SELECT
1190
1191    END SUBROUTINE get_next_arg
1192
1193
1194END MODULE wrk_nemo
Note: See TracBrowser for help on using the repository browser.