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 @ 2598

Last change on this file since 2598 was 2598, checked in by gm, 13 years ago

dynamic mem: #785 ; LIM-3 case: add TARGET for 4D arrays + style
File size: 43.2 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, num_4d_wrkspaces)
37   INTEGER, PARAMETER :: max_num_wrkspaces = 35
38
39   ! If adding more arrays here, remember to increment the appropriate
40   ! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc()
41
42   !                                                                    !!**  1D, REAL(wp) workspaces  **
43   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_1 , wrk_1d_2 , wrk_1d_3 , wrk_1d_4 , wrk_1d_5
44   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_6 , wrk_1d_7 , wrk_1d_8 , wrk_1d_9 , wrk_1d_10
45   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_11, wrk_1d_12, wrk_1d_13, wrk_1d_14, wrk_1d_15
46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_16, wrk_1d_17, wrk_1d_18, wrk_1d_19, wrk_1d_20
47   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_21, wrk_1d_22, wrk_1d_23, wrk_1d_24, wrk_1d_25
48   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)      , TARGET, PUBLIC ::   wrk_1d_26, wrk_1d_27
49
50   !                                                                    !!**  2D, x-y, REAL(wp) workspaces  **
51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_1 , wrk_2d_2 , wrk_2d_3 , wrk_2d_4 , wrk_2d_5
52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_6 , wrk_2d_7 , wrk_2d_8 , wrk_2d_9 , wrk_2d_10
53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_11, wrk_2d_12, wrk_2d_13, wrk_2d_14, wrk_2d_15
54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_16, wrk_2d_17, wrk_2d_18, wrk_2d_19, wrk_2d_20
55   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_21, wrk_2d_22, wrk_2d_23, wrk_2d_24, wrk_2d_25
56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_26, wrk_2d_27, wrk_2d_28, wrk_2d_29, wrk_2d_30
57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)    , TARGET, PUBLIC ::   wrk_2d_31, wrk_2d_32, wrk_2d_33, wrk_2d_34, wrk_2d_35
58
59   !                                                                    !!**  2D, x-z, REAL(wp) workspaces  **
60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)            , PUBLIC ::   wrk_xz_1, wrk_xz_2, wrk_xz_3, wrk_xz_4 
61   
62   !                                                                    !!**  3D, x-y-z, REAL(wp) workspaces  **
63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  , TARGET, PUBLIC ::   wrk_3d_1 , wrk_3d_2 , wrk_3d_3 , wrk_3d_4 , wrk_3d_5
64   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  , TARGET, PUBLIC ::   wrk_3d_6 , wrk_3d_7 , wrk_3d_8 , wrk_3d_9 , wrk_3d_10
65   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)  , TARGET, PUBLIC ::   wrk_3d_11, wrk_3d_12, wrk_3d_13, wrk_3d_14, wrk_3d_15
66
67   !                                                                    !!**  4D, x-y-z-tra, REAL(wp) workspaces  **
68   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:), TARGET, PUBLIC ::   wrk_4d_1, wrk_4d_2, wrk_4d_3, wrk_4d_4 
69
70
71   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)            , PUBLIC ::   llwrk_2d_1, llwrk_2d_2, llwrk_2d_3 !: 2D logical workspace
72   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:,:)  , TARGET, PUBLIC ::   llwrk_3d_1 !: 3D logical workspace
73   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:)            , PUBLIC ::   iwrk_2d_1 !: 2D integer workspace
74
75   LOGICAL, DIMENSION(num_1d_wrkspaces)  :: in_use_1d     !: Flags to track which 1D workspace arrays are in use 
76   LOGICAL, DIMENSION(num_2d_wrkspaces)  :: in_use_2d     !: Flags to track which 2D workspace arrays are in use
77   LOGICAL, DIMENSION(num_3d_wrkspaces)  :: in_use_3d     !: Flags to track which 3D workspace arrays are in use
78   LOGICAL, DIMENSION(num_4d_wrkspaces)  :: in_use_4d     !: Flags to track which 4D workspace arrays are in use
79   LOGICAL, DIMENSION(num_xz_wrkspaces)  :: in_use_xz     !: Flags to track which 2D, xz workspace arrays are in use
80   LOGICAL, DIMENSION(num_2d_lwrkspaces) :: in_use_2dll   !: Flags to track which 2D, logical workspace arrays are in use
81   LOGICAL, DIMENSION(num_3d_lwrkspaces) :: in_use_3dll   !: Flags to track which 3D, logical workspace arrays are in use
82   LOGICAL, DIMENSION(num_2d_iwrkspaces) :: in_use_2di    !: Flags to track which 2D, integer workspace arrays are in use
83
84   ! Labels for specifying workspace type in call to print_in_use_list()
85   INTEGER, PARAMETER :: INTEGER_TYPE = 0
86   INTEGER, PARAMETER :: LOGICAL_TYPE = 1
87   INTEGER, PARAMETER :: REAL_TYPE    = 2
88
89   !!----------------------------------------------------------------------
90   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
91   !! $Id$
92   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
93   !!----------------------------------------------------------------------
94CONTAINS
95
96  FUNCTION wrk_alloc()
97      !!----------------------------------------------------------------------
98      !!                   ***  FUNCTION wrk_alloc  ***
99      !!
100      !! ** Purpose :   Define in memory once for all the NEMO 2D, 3D and 4d
101      !!                work space arrays
102      !!----------------------------------------------------------------------
103      INTEGER :: wrk_alloc     ! Return value
104      INTEGER :: extent_1d     ! Extent to allocate for 1D arrays
105      INTEGER :: ierror(8)     ! local integer
106      !!----------------------------------------------------------------------
107      !
108      ! Extent to use for 1D work arrays - find the maximum product of jpi*jpj, jpi*jpk and jpj*jpk and use that
109      IF    ( jpi < jpj .AND. jpi < jpk ) THEN   ;   extent_1d = jpj*jpk
110      ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN   ;   extent_1d = jpi*jpk
111      ELSE                                       ;   extent_1d = jpi*jpj
112      END IF
113      !
114      ! Initialise the 'in use' flags for each work-space array
115      in_use_1d  (:) = .FALSE.
116      in_use_2d  (:) = .FALSE.
117      in_use_3d  (:) = .FALSE.
118      in_use_4d  (:) = .FALSE.
119      in_use_xz  (:) = .FALSE.
120      in_use_2dll(:) = .FALSE.
121      in_use_3dll(:) = .FALSE.
122      in_use_2di (:) = .FALSE.
123     
124      ierror(:) = 0
125
126      ALLOCATE( wrk_1d_1 (extent_1d) , wrk_1d_2 (extent_1d) , wrk_1d_3 (extent_1d) , wrk_1d_4 (extent_1d) ,     &
127         &      wrk_1d_5 (extent_1d) , wrk_1d_6 (extent_1d) , wrk_1d_7 (extent_1d) , wrk_1d_8 (extent_1d) ,     &
128         &      wrk_1d_9 (extent_1d) , wrk_1d_10(extent_1d)                                               ,     &
129         &      wrk_1d_11(extent_1d) , wrk_1d_12(extent_1d) , wrk_1d_13(extent_1d) , wrk_1d_14(extent_1d) ,     &
130         &      wrk_1d_15(extent_1d) , wrk_1d_16(extent_1d) , wrk_1d_17(extent_1d) , wrk_1d_18(extent_1d) ,     &
131         &      wrk_1d_19(extent_1d) , wrk_1d_20(extent_1d)                                               ,     &
132         &      wrk_1d_21(extent_1d) , wrk_1d_22(extent_1d) , wrk_1d_23(extent_1d) , wrk_1d_24(extent_1d) ,     &
133         &      wrk_1d_25(extent_1d) , wrk_1d_26(extent_1d) , wrk_1d_27(extent_1d)                        , STAT=ierror(1) )
134      !
135      ALLOCATE( wrk_2d_1 (jpi,jpj) , wrk_2d_2 (jpi,jpj) , wrk_2d_3 (jpi,jpj) , wrk_2d_4 (jpi,jpj) ,     & 
136         &      wrk_2d_5 (jpi,jpj) , wrk_2d_6 (jpi,jpj) , wrk_2d_7 (jpi,jpj) , wrk_2d_8 (jpi,jpj) ,     &
137         &      wrk_2d_9 (jpi,jpj) , wrk_2d_10(jpi,jpj)                                           ,     &
138         &      wrk_2d_11(jpi,jpj) , wrk_2d_12(jpi,jpj) , wrk_2d_13(jpi,jpj) , wrk_2d_14(jpi,jpj) ,     &
139         &      wrk_2d_15(jpi,jpj) , wrk_2d_16(jpi,jpj) , wrk_2d_17(jpi,jpj) , wrk_2d_18(jpi,jpj) ,     &
140         &      wrk_2d_19(jpi,jpj) , wrk_2d_20(jpi,jpj)                                           ,     &
141         &      wrk_2d_21(jpi,jpj) , wrk_2d_22(jpi,jpj) , wrk_2d_23(jpi,jpj) , wrk_2d_24(jpi,jpj) ,     &
142         &      wrk_2d_25(jpi,jpj) , wrk_2d_26(jpi,jpj) , wrk_2d_27(jpi,jpj) , wrk_2d_28(jpi,jpj) ,     &
143         &      wrk_2d_29(jpi,jpj) , wrk_2d_30(jpi,jpj)                                           ,     &
144         &      wrk_2d_31(jpi,jpj) , wrk_2d_32(jpi,jpj) , wrk_2d_33(jpi,jpj) , wrk_2d_34(jpi,jpj) ,     &
145         &      wrk_2d_35(jpi,jpj)                                                                , STAT=ierror(2) )
146      !
147      ALLOCATE( wrk_3d_1 (jpi,jpj,jpk) , wrk_3d_2 (jpi,jpj,jpk) , wrk_3d_3 (jpi,jpj,jpk) , wrk_3d_4 (jpi,jpj,jpk) ,     &
148         &      wrk_3d_5 (jpi,jpj,jpk) , wrk_3d_6 (jpi,jpj,jpk) , wrk_3d_7 (jpi,jpj,jpk) , wrk_3d_8 (jpi,jpj,jpk) ,     &
149         &      wrk_3d_9 (jpi,jpj,jpk) , wrk_3d_10(jpi,jpj,jpk)                                                   ,     & 
150         &      wrk_3d_11(jpi,jpj,jpk) , wrk_3d_12(jpi,jpj,jpk) , wrk_3d_13(jpi,jpj,jpk) , wrk_3d_14(jpi,jpj,jpk) ,     & 
151         &      wrk_3d_15(jpi,jpj,jpk)                                                                            , STAT=ierror(3) )
152      !
153      ALLOCATE( wrk_4d_1(jpi,jpj,jpk,jpts) , wrk_4d_2(jpi,jpj,jpk,jpts),     &
154         &      wrk_4d_3(jpi,jpj,jpk,jpts) , wrk_4d_4(jpi,jpj,jpk,jpts), STAT=ierror(4) )
155      !
156      ALLOCATE( wrk_xz_1(jpi,jpk) , wrk_xz_2(jpi,jpk) , wrk_xz_3(jpi,jpk) , wrk_xz_4(jpi,jpk) , STAT=ierror(5) )
157      !
158      ALLOCATE( llwrk_2d_1(jpi,jpj) , llwrk_2d_2(jpi,jpj) , llwrk_2d_3(jpi,jpj)               , STAT=ierror(6) )
159      !
160      ALLOCATE( llwrk_3d_1(jpi,jpj,jpk) , STAT=ierror(7) )
161      !
162      ALLOCATE( iwrk_2d_1(jpi,jpj)      , STAT=ierror(8) )
163      !
164      wrk_alloc = MAXVAL( ierror )
165
166      ! Calling routine, nemo_alloc(), checks for errors and takes
167      ! appropriate action - we just print a warning message
168      IF( wrk_alloc /= 0 )   CALL ctl_warn('wrk_alloc: allocation of workspace arrays failed')
169      !
170   END FUNCTION wrk_alloc
171
172
173   FUNCTION wrk_use( kdim,    index1,  index2,  index3,  index4,    &
174      &              index5,  index6,  index7,  index8,  index9,    &
175      &              index10, index11, index12, index13, index14,   &
176      &              index15, index16, index17, index18, index19,   &
177      &              index20, index21, index22, index23, index24,   &
178      &              index25, index26, index27)
179      !!----------------------------------------------------------------------
180      !!                   ***  FUNCTION wrk_use  ***
181      !!
182      !! ** Purpose :   Request a set of KIND(wp) workspaces to use. Returns
183      !!                .TRUE. if all those requested are available, .FALSE. otherwise.
184      !!
185      !! ** Method  :   Sets internal flags to signal that requested workspaces are in use.
186      !!----------------------------------------------------------------------
187      INTEGER, INTENT(in) ::   kdim        ! Dimensionality of requested workspace(s)
188      INTEGER, INTENT(in) ::   index1      ! Index of first requested workspace
189      INTEGER, OPTIONAL, INTENT(in) ::            index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9, index10
190      INTEGER, OPTIONAL, INTENT(in) ::   index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
191      INTEGER, OPTIONAL, INTENT(in) ::   index21, index22, index23, index24, index25, index26, index27
192      !
193      LOGICAL ::   wrk_use      ! Return value
194      INTEGER ::   iarg, iptr   ! local integer
195      !!----------------------------------------------------------------------
196
197      wrk_use = .TRUE.
198      iptr    = index1
199      iarg    = 1
200     
201      DO WHILE( wrk_use .AND. iarg <= max_num_wrkspaces )
202         !
203         IF( kdim == 1 ) THEN
204            IF( iptr > num_1d_wrkspaces ) THEN
205               CALL ctl_stop('wrk_use - more 1D workspace arrays requested than defined in wrk_nemo module')
206               wrk_use = .FALSE.
207               EXIT
208            ELSEIF( in_use_1d(iptr) ) THEN
209               wrk_use = .FALSE.
210               CALL print_in_use_list(1, REAL_TYPE, in_use_1d)
211            ENDIF
212            in_use_1d(iptr) = .TRUE.
213            !
214         ELSEIF( kdim == 2 ) THEN
215            IF( iptr > num_2d_wrkspaces ) THEN
216               CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')
217               wrk_use = .FALSE.
218               EXIT
219            ELSEIF( in_use_2d(iptr) ) THEN
220               wrk_use = .FALSE.
221               CALL print_in_use_list(2, REAL_TYPE, in_use_2d)
222            ENDIF
223            in_use_2d(iptr) = .TRUE.
224            !
225         ELSEIF( kdim == 3 ) THEN
226            IF( iptr > num_3d_wrkspaces ) THEN
227               CALL ctl_stop( 'wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module' )
228               wrk_use = .FALSE.
229               EXIT
230            ELSEIF( in_use_3d(iptr) ) THEN
231               wrk_use = .FALSE.
232               CALL print_in_use_list(3, REAL_TYPE, in_use_3d)
233            ENDIF
234            in_use_3d(iptr) = .TRUE.
235            !
236         ELSEIF( kdim == 4 ) THEN
237            IF(iptr > num_4d_wrkspaces)THEN
238               CALL ctl_stop( 'wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module' )
239               wrk_use = .FALSE.
240               EXIT
241            ELSEIF( in_use_4d(iptr) ) THEN
242               wrk_use = .FALSE.
243               CALL print_in_use_list( 4, REAL_TYPE, in_use_4d )
244            ENDIF
245            !
246            in_use_4d(iptr) = .TRUE.
247            !
248         ELSE
249            IF(lwp) WRITE(numout,*) 'wrk_use: unsupported value of kdim = ',kdim
250            CALL ctl_stop( 'wrk_use: unrecognised value for number of dimensions' )
251         END IF
252
253         CALL get_next_arg( iarg  ,  iptr  ,  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         IF( iarg == -1 ) THEN      ! We've checked all of the arguments and are done
261            EXIT
262         ELSEIF( iarg == -99 ) THEN
263            CALL ctl_stop( 'wrk_use - ERROR, caught unexpected argument count - BUG' )
264            EXIT
265         END IF
266         !
267      END DO ! end of DO WHILE()
268      !
269    END FUNCTION wrk_use
270
271
272   FUNCTION llwrk_use( kdim,   index1, index2, index3, index4,   &
273      &                index5, index6, index7, index8, index9)
274      !!----------------------------------------------------------------------
275      !!                   ***  FUNCTION llwrk_use  ***
276      !!
277      !! ** Purpose :   Request a set of LOGICAL workspaces to use. Returns
278      !!                .TRUE. if all those requested are available, .FALSE. otherwise.
279      !!
280      !! ** Method  :   Sets internal flags to signal that requested workspaces are in use.
281      !!----------------------------------------------------------------------
282      INTEGER, INTENT(in) ::   kdim     ! Dimensionality of requested workspace(s)
283      INTEGER, INTENT(in) ::   index1   ! Index of first requested workspace
284      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9
285      !
286      LOGICAL ::   llwrk_use     ! Return value
287      INTEGER ::   iarg, iptr    ! local integers
288      !!----------------------------------------------------------------------
289      !
290      llwrk_use = .TRUE.
291      iptr      = index1
292      iarg      = 1
293      !
294      DO WHILE( llwrk_use .AND. iarg <= max_num_wrkspaces )
295         !
296         IF( kdim == 2 ) THEN
297            IF(iptr > num_2d_lwrkspaces)THEN
298               CALL ctl_stop('llwrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')
299               llwrk_use = .FALSE.
300               EXIT
301            ELSE IF( in_use_2dll(iptr) )THEN
302               llwrk_use = .FALSE.
303               CALL print_in_use_list(2, REAL_TYPE, in_use_2d)
304            END IF
305            in_use_2dll(iptr) = .TRUE.
306            !
307         ELSE IF (kdim == 3)THEN
308            !
309            IF(iptr > num_3d_lwrkspaces)THEN
310               CALL ctl_stop('llwrk_use - more 3D workspace arrays requested than defined in wrk_nemo module')
311               llwrk_use = .FALSE.
312               EXIT
313            ELSE IF( in_use_3dll(iptr) )THEN
314               llwrk_use = .FALSE.
315               CALL print_in_use_list(3, REAL_TYPE, in_use_3d)
316            END IF
317            !
318            in_use_3dll(iptr) = .TRUE.
319         ELSE
320            IF(lwp) WRITE(numout,*) 'llwrk_use: unsupported value of kdim = ',kdim
321            CALL ctl_stop('llwrk_use: unrecognised value for number of dimensions')
322         END IF
323
324         CALL get_next_arg( iarg  , iptr  , index2, index3, index4, &
325            &               index5, index6, index7, index8, index9)
326
327         IF( iarg == -1 ) THEN      ! We've checked all of the arguments and are done
328            EXIT
329         ELSEIF( iarg == -99 ) THEN
330            CALL ctl_stop( 'llwrk_use - ERROR, caught unexpected argument count - BUG' )
331            EXIT
332         ENDIF
333         !
334      END DO ! while(llwrk_use .AND. iarg <= max_num_wrkspaces)
335      !
336   END FUNCTION llwrk_use
337
338
339   FUNCTION iwrk_use( kdim, index1, index2, index3, index4,   &
340      &                     index5, index6, index7 )
341      !!----------------------------------------------------------------------
342      !!                   ***  FUNCTION iwrk_use  ***
343      !!
344      !! ** Purpose :   Request a set of INTEGER workspaces to use. Returns
345      !!                .TRUE. if all those requested are available, .FALSE. otherwise.
346      !!
347      !! ** Method  :   Sets internal flags to signal that requested workspaces are in use.
348      !!----------------------------------------------------------------------
349      INTEGER          , INTENT(in) :: kdim        ! Dimensionality of requested workspace(s)
350      INTEGER          , INTENT(in) :: index1      ! Index of first requested workspace
351      INTEGER, OPTIONAL, INTENT(in) ::   index2, index3, index4, index5, index6, index7
352      !
353      LOGICAL             :: iwrk_use    ! Return value
354      INTEGER :: iarg, iptr
355      !!----------------------------------------------------------------------
356
357      iwrk_use = .TRUE.
358      iptr     = index1
359      iarg     = 1
360     
361      DO WHILE( iwrk_use .AND. iarg <= max_num_wrkspaces )
362         !
363         IF( kdim == 2 ) THEN
364            IF( iptr > num_2d_wrkspaces ) THEN
365               CALL ctl_stop( 'wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module' )
366               iwrk_use = .FALSE.
367            ELSEIF( in_use_2di(iptr) ) THEN
368               iwrk_use = .FALSE.
369               CALL print_in_use_list( 2, INTEGER_TYPE, in_use_2di )
370            END IF
371            in_use_2di(iptr) = .TRUE.
372            !
373         ELSE
374            IF(lwp) WRITE(numout,*) 'iwrk_use: unsupported value of kdim = ',kdim
375            CALL ctl_stop('iwrk_use: unsupported value for number of dimensions')
376         END IF
377
378         ! Move on to next optional argument
379         SELECT CASE (iarg)
380         CASE ( 1 )
381            IF( .NOT. PRESENT(index2) ) THEN   ;   EXIT
382            ELSE                               ;   iarg = 2   ;   iptr = index2
383            END IF
384         CASE ( 2 )
385            IF( .NOT. PRESENT(index3) ) THEN   ;   EXIT
386            ELSE                               ;   iarg = 3   ;   iptr = index3
387            END IF
388         CASE ( 3 )
389            IF( .NOT. PRESENT(index4) ) THEN   ;   EXIT
390            ELSE                               ;   iarg = 4   ;   iptr = index4
391            END IF
392         CASE ( 4 )
393            IF( .NOT. PRESENT(index5) ) THEN   ;   EXIT
394            ELSE                               ;   iarg = 5   ;   iptr = index5
395            END IF
396         CASE ( 5 )
397            IF( .NOT. PRESENT(index6) ) THEN   ;   EXIT
398            ELSE                               ;   iarg = 6   ;   iptr = index6
399            END IF
400         CASE ( 6 )
401            IF( .NOT. PRESENT(index7) ) THEN   ;   EXIT
402            ELSE                               ;   iarg = 7   ;   iptr = index7
403            END IF
404         CASE ( 7 )
405            EXIT
406         CASE DEFAULT
407            CALL ctl_stop( 'iwrk_use - ERROR, caught unexpected argument count - BUG' )
408            EXIT
409         END SELECT
410         !
411      END DO ! end of DO WHILE()
412      !
413    END FUNCTION iwrk_use
414
415
416   FUNCTION wrk_use_xz( index1, index2, index3, index4,   &
417      &                 index5, index6, index7, index8, index9 )
418      !!----------------------------------------------------------------------
419      !!                   ***  FUNCTION wrk_use_xz  ***
420      !!
421      !! ** Purpose :   Request a set of 2D, xz (jpi,jpk) workspaces to use.
422      !!                Returns .TRUE. if all those requested are available,
423      !!                .FALSE. otherwise.
424      !!
425      !! ** Method  :   Sets internal flags to signal that requested workspaces are in use.
426      !!----------------------------------------------------------------------
427      INTEGER          , INTENT(in) :: index1      ! Index of first requested workspace
428      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9
429      ! Local variables
430      LOGICAL ::   wrk_use_xz   ! Return value
431      INTEGER ::   iarg, iptr   ! local integer
432      !!----------------------------------------------------------------------
433
434      wrk_use_xz = .TRUE.
435      iptr       = index1
436      iarg       = 1
437       
438      DO WHILE( wrk_use_xz .AND. iarg <= max_num_wrkspaces )
439         !
440         IF(iptr > num_xz_wrkspaces)THEN
441            CALL ctl_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module')
442            wrk_use_xz = .FALSE.
443            EXIT
444         ELSE IF( in_use_xz(iptr) )THEN
445            wrk_use_xz = .FALSE.
446            CALL print_in_use_list(2, REAL_TYPE, in_use_xz) !ARPDBG - bug
447         END IF
448         !
449         in_use_xz(iptr) = .TRUE.
450         !
451         CALL get_next_arg(iarg  , iptr  , index2, index3, index4, &
452            &              index5, index6, index7, index8, index9)
453         !
454         IF( iarg == -1 ) THEN      ! We've checked all of the arguments and are done
455            EXIT
456         ELSEIF( iarg == -99 ) THEN
457            CALL ctl_stop( 'wrk_use_xz - ERROR, caught unexpected argument count - BUG' )   ;   EXIT
458         END IF
459         !
460      END DO ! while(wrk_use_xz .AND. iarg <= max_num_wrkspaces)
461      !
462   END FUNCTION wrk_use_xz
463
464
465   FUNCTION wrk_release( kdim,    index1,  index2,  index3,  index4,  &
466      &                  index5,  index6,  index7,  index8,  index9,  &
467      &                  index10, index11, index12, index13, index14, &
468      &                  index15, index16, index17, index18, index19, &
469      &                  index20, index21, index22, index23, index24, &
470      &                  index25, index26, index27)
471      !!----------------------------------------------------------------------
472      !!                 ***  FUNCTION wrk_release  ***
473      !!
474      !! ** Purpose :   Flag that the specified workspace arrays are no-longer in use.
475      !!----------------------------------------------------------------------
476      LOGICAL             :: wrk_release ! Return value
477      INTEGER, INTENT(in) :: kdim             ! Dimensionality of workspace(s)
478      INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
479      INTEGER, OPTIONAL, INTENT(in) ::            index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10
480      INTEGER, OPTIONAL, INTENT(in) ::   index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
481      INTEGER, OPTIONAL, INTENT(in) ::   index21, index22, index23, index24, index25, index26, index27
482      !
483      INTEGER :: iarg, iptr
484      !!----------------------------------------------------------------------
485
486      wrk_release = .TRUE.
487      iptr = index1
488      iarg = 1
489
490      DO WHILE( iarg <= max_num_wrkspaces )
491         !
492         IF( kdim == 1 ) THEN
493            IF( iptr > num_1d_wrkspaces ) THEN
494               CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 1D workspace array' )
495               wrk_release = .FALSE.
496            ELSE
497               in_use_1d(iptr) = .FALSE.
498            ENDIF
499            !
500         ELSE IF(kdim == 2)THEN
501            IF( iptr > num_2d_wrkspaces ) THEN
502               CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 2D workspace array' )
503               wrk_release = .FALSE.
504            ENDIF
505            in_use_2d(iptr) = .FALSE.
506            !
507         ELSEIF( kdim == 3 ) THEN
508            IF( iptr > num_3d_wrkspaces ) THEN
509               CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 3D workspace array')
510               wrk_release = .FALSE.
511            END IF
512            in_use_3d(iptr) = .FALSE.
513            !
514          ELSEIF( kdim == 4 ) THEN
515            IF(iptr > num_4d_wrkspaces)THEN
516               CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 4D workspace array')
517               wrk_release = .FALSE.
518            END IF
519            in_use_4d(iptr) = .FALSE.
520            !
521         ELSE
522            IF(lwp) WRITE(numout,*) 'wrk_release: unsupported value of kdim = ',kdim
523            CALL ctl_stop('wrk_release: unrecognised value for number of dimensions')
524         ENDIF
525         
526         ! Move on to next optional argument
527         CALL get_next_arg( iarg  ,  iptr  ,  index2,  index3,  index4,   &
528            &               index5,  index6,  index7,  index8,  index9,   &
529            &               index10, index11, index12, index13,           &
530            &               index14, index15, index16, index17,           &
531            &               index18, index19, index20, index21,           &
532            &               index22, index23, index24, index25,           &
533            &               index26, index27 )
534
535         IF( iarg == -1 ) THEN      ! We've checked all of the arguments and are done
536            EXIT
537         ELSEIF( iarg == -99 ) THEN
538             CALL ctl_stop('wrk_release - caught unexpected argument count - BUG')   ;   EXIT
539         END IF
540         !
541      END DO ! end of DO WHILE()
542      !
543   END FUNCTION wrk_release
544
545
546   FUNCTION llwrk_release( kdim, index1, index2, index3, index4, index5,   &
547      &                          index6, index7, index8, index9 )
548      !!----------------------------------------------------------------------
549      !!                 ***  FUNCTION wrk_release  ***
550      !!----------------------------------------------------------------------
551      INTEGER          , INTENT(in) ::   kdim             ! Dimensionality of workspace(s)
552      INTEGER          , INTENT(in) ::   index1           ! Index of 1st workspace to release
553      INTEGER, OPTIONAL, INTENT(in) ::   index2, index3, index4, index5, index6, index7, index8, index9
554      !
555      LOGICAL ::   llwrk_release   ! Return value
556      INTEGER ::   iarg, iptr      ! local integer
557      !!----------------------------------------------------------------------
558      !
559      llwrk_release = .TRUE.
560      iptr = index1
561      iarg = 1
562      !
563      DO WHILE(iarg <= max_num_wrkspaces)
564         !
565         IF( kdim == 2 ) THEN
566            !
567            IF( iptr > num_2d_lwrkspaces ) THEN
568               CALL ctl_stop( 'llwrk_release - ERROR - attempt to release a non-existant 2D workspace array' )
569               llwrk_release = .FALSE.
570               EXIT
571            ENDIF
572            in_use_2dll(iptr) = .FALSE.
573            !
574         ELSEIF( kdim == 3 ) THEN
575            IF( iptr > num_3d_lwrkspaces ) THEN
576               CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 3D workspace array')
577               llwrk_release = .FALSE.
578               EXIT
579            ENDIF
580            in_use_3dll(iptr) = .FALSE.
581            !
582         ELSE
583            IF(lwp) WRITE(numout,*) 'llwrk_release: unsupported value of kdim = ', kdim
584            CALL ctl_stop( 'llwrk_release: unrecognised value for number of dimensions' )
585         END IF
586         !
587         ! Move on to next optional argument
588         CALL get_next_arg(iarg, iptr, index2, index3, index4,   &
589            &                          index5, index6, index7, index8, index9)
590         !
591         IF( iarg == -1 ) THEN         ! We've checked all of the arguments and are done
592             EXIT
593         ELSEIF( iarg == -99 ) THEN
594            CALL ctl_stop( 'llwrk_release - ERROR, caught unexpected argument count - BUG' )   ;   EXIT
595         ENDIF
596         !
597      END DO ! while (iarg <= max_num_wrkspaces)
598      !
599   END FUNCTION llwrk_release
600
601
602   FUNCTION iwrk_release( kdim, index1, index2, index3, index4,   &
603      &                         index5, index6, index7 )
604      !!----------------------------------------------------------------------
605      !!                 ***  FUNCTION iwrk_release  ***
606      !!
607      !! ** Purpose :   Flag that the specified INTEGER workspace arrays are
608      !!                no-longer in use.
609      !!----------------------------------------------------------------------
610      INTEGER, INTENT(in) ::   kdim             ! Dimensionality of workspace(s)
611      INTEGER, INTENT(in) ::   index1           ! Index of 1st workspace to release
612      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7
613      !
614      LOGICAL :: iwrk_release   ! Return value
615      INTEGER :: iarg, iptr     ! local integer
616      !!----------------------------------------------------------------------
617      !
618      iwrk_release = .TRUE.
619      iptr         = index1
620      iarg         = 1
621      !
622      DO WHILE(iarg <= max_num_wrkspaces)
623         !
624         IF( kdim == 2 ) THEN
625            IF( iptr > num_2d_iwrkspaces ) THEN
626               CALL ctl_stop('iwrk_release - ERROR - attempt to release a non-existant 2D workspace array')
627               iwrk_release = .FALSE.
628            ENDIF
629            in_use_2di(iptr) = .FALSE.
630         ELSE
631            IF(lwp) WRITE(numout,*) 'iwrk_release: unsupported value of kdim = ',kdim
632            CALL ctl_stop('iwrk_release: unsupported value for number of dimensions')
633         ENDIF
634         !
635         ! Move on to next optional argument
636         SELECT CASE (iarg)
637         CASE ( 1 )
638            IF( .NOT. PRESENT(index2) ) THEN   ;   EXIT
639            ELSE                               ;   iarg = 2   ;   iptr = index2
640            END IF
641         CASE ( 2 )
642            IF( .NOT. PRESENT(index3) ) THEN   ;   EXIT
643            ELSE                               ;   iarg = 3   ;   iptr = index3
644            END IF
645         CASE ( 3 )
646            IF( .NOT. PRESENT(index4) ) THEN   ;   EXIT
647            ELSE                               ;   iarg = 4   ;   iptr = index4
648            END IF
649         CASE ( 4 )
650            IF( .NOT. PRESENT(index5) ) THEN   ;   EXIT
651            ELSE                               ;   iarg = 5   ;   iptr = index5
652            END IF
653         CASE ( 5 )
654            IF( .NOT. PRESENT(index6) ) THEN   ;   EXIT
655            ELSE                               ;   iarg = 6   ;   iptr = index6
656            END IF
657         CASE ( 6 )
658            IF( .NOT. PRESENT(index7) ) THEN   ;   EXIT
659            ELSE                               ;   iarg = 7   ;   iptr = index7
660            END IF
661         CASE ( 7 )
662            EXIT
663         CASE DEFAULT
664            CALL ctl_stop( 'iwrk_release - ERROR, caught unexpected argument count - BUG' )
665            EXIT
666         END SELECT
667         !
668      END DO ! end of DO WHILE()
669      !
670   END FUNCTION iwrk_release
671
672
673   FUNCTION wrk_release_xz( index1, index2, index3, index4, index5,   &
674      &                     index6, index7, index8, index9 )
675      !!----------------------------------------------------------------------
676      !!                 ***  FUNCTION wrk_release_xz  ***
677      !!
678      !!----------------------------------------------------------------------
679      INTEGER, INTENT(in) :: index1           ! Index of 1st workspace to release
680      INTEGER, OPTIONAL, INTENT(in) :: index2, index3, index4, index5, index6, index7, index8, index9
681      !
682      LOGICAL ::   wrk_release_xz   ! Return value
683      INTEGER ::   iarg, iptr       ! local integer
684      !!----------------------------------------------------------------------
685      !
686      wrk_release_xz = .TRUE.
687      iptr           = index1
688      iarg           = 1
689      !
690      DO WHILE( iarg <= max_num_wrkspaces )
691         !
692         IF( iptr > num_xz_wrkspaces ) THEN
693            CALL ctl_stop('wrk_release_xz - ERROR - attempt to release a non-existant 2D xz workspace array')
694            wrk_release_xz = .FALSE.
695            EXIT
696         ENDIF
697         in_use_xz(iptr) = .FALSE.
698         !
699         ! Move on to next optional argument
700         CALL get_next_arg( iarg, iptr, index2, index3, index4,   &
701            &                           index5, index6, index7, index8, index9)
702         !
703         IF(  iarg == -1 ) THEN     ! We've checked all of the arguments and are done
704            EXIT
705         ELSEIF( iarg == -99 ) THEN
706            CALL ctl_stop('wrk_release_xz - ERROR, caught unexpected argument count - BUG')
707            EXIT
708         END IF
709         !
710      END DO ! while (iarg <= max_num_wrkspaces)
711      !
712   END FUNCTION wrk_release_xz
713
714
715   SUBROUTINE print_in_use_list( kdim, itype, in_use_list )
716      !!----------------------------------------------------------------------
717      !!                 *** ROUTINE print_in_use_list ***
718      !!
719      !!    Purpose: to print out the table holding which workspace arrays
720      !!             are currently marked as in use.
721      !!----------------------------------------------------------------------
722      INTEGER,               INTENT(in) :: kdim
723      INTEGER,               INTENT(in) :: itype
724      LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list
725      !
726      INTEGER          ::   ji, icount
727      CHARACTER(LEN=7) ::   type_string
728      !!----------------------------------------------------------------------
729
730      IF(.NOT. lwp)   RETURN
731
732      SELECT CASE ( kdim )
733      !
734      CASE (1)
735         SELECT CASE (itype)
736         CASE (INTEGER_TYPE)   ;   icount = num_1d_iwrkspaces
737         CASE (LOGICAL_TYPE)   ;   icount = num_1d_lwrkspaces
738         CASE (REAL_TYPE   )   ;   icount = num_1d_wrkspaces
739         END SELECT
740         !
741      CASE (2)
742         SELECT CASE (itype)
743         CASE (INTEGER_TYPE)   ;   icount = num_2d_iwrkspaces
744         CASE (LOGICAL_TYPE)   ;   icount = num_2d_lwrkspaces
745         CASE (REAL_TYPE   )   ;   icount = num_2d_wrkspaces
746         END SELECT
747         !
748      CASE (3)
749         SELECT CASE (itype)
750         CASE (INTEGER_TYPE)   ;   icount = num_3d_iwrkspaces
751         CASE (LOGICAL_TYPE)   ;   icount = num_3d_lwrkspaces
752         CASE (REAL_TYPE   )   ;   icount = num_3d_wrkspaces
753         END SELECT
754         !
755      CASE (4)
756         SELECT CASE (itype)
757         CASE (INTEGER_TYPE)   ;   icount = num_4d_iwrkspaces
758         CASE (LOGICAL_TYPE)   ;   icount = num_4d_lwrkspaces
759         CASE (REAL_TYPE   )   ;   icount = num_4d_wrkspaces
760         END SELECT
761         !
762      CASE DEFAULT   ;   RETURN
763      !
764      END SELECT
765
766      ! Set character string with type of workspace
767      SELECT CASE (itype)
768      CASE (INTEGER_TYPE)   ;   type_string = "INTEGER" 
769      CASE (LOGICAL_TYPE)   ;   type_string = "LOGICAL"
770      CASE (REAL_TYPE   )   ;   type_string = "REAL" 
771      END SELECT
772
773      WRITE(numout,*)
774      WRITE(numout,"('------------------------------------------')")
775      WRITE(numout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string)
776      WRITE(numout,"('Workspace   In use')")
777      DO ji = 1, icount, 1
778         WRITE(numout,"(4x,I2,8x,L1)") ji, in_use_list(ji)
779      END DO
780      WRITE(numout,"('------------------------------------------')")
781      WRITE(numout,*)
782      !
783   END SUBROUTINE print_in_use_list
784
785
786   SUBROUTINE get_next_arg( iargidx, iargval, index2,  index3,  index4,  &
787      &                     index5 , index6,  index7,  index8,  index9,  &
788      &                     index10, index11, index12, index13, index14, &
789      &                     index15, index16, index17, index18, index19, &
790      &                     index20, index21, index22, index23, index24, &
791      &                     index25, index26, index27 )
792      !!----------------------------------------------------------------------
793      INTEGER, INTENT(inout) :: iargidx ! Index of current arg
794      INTEGER, INTENT(inout) :: iargval ! Value of current arg
795      INTEGER, OPTIONAL, INTENT(in) ::            index2 , index3 , index4 , index5 , index6 , index7 , index8 , index9 , index10
796      INTEGER, OPTIONAL, INTENT(in) ::   index11, index12, index13, index14, index15, index16, index17, index18, index19, index20
797      INTEGER, OPTIONAL, INTENT(in) ::   index21, index22, index23, index24, index25, index26, index27
798      !!----------------------------------------------------------------------
799
800      SELECT CASE (iargidx)       ! Move on to next optional argument
801      CASE ( 1 )
802         IF( .NOT. PRESENT(index2 ) ) THEN   ;   iargidx = -1
803         ELSE                                ;   iargidx =  2   ;   iargval = index2
804         ENDIF
805      CASE ( 2 )
806         IF( .NOT. PRESENT(index3 ) ) THEN   ;   iargidx = -1
807         ELSE                                ;   iargidx =  3   ;   iargval = index3
808         ENDIF
809      CASE ( 3 )
810         IF( .NOT. PRESENT(index4 ) ) THEN   ;   iargidx = -1
811         ELSE                                ;   iargidx =  4   ;   iargval = index4
812         ENDIF
813      CASE ( 4 )
814         IF( .NOT. PRESENT(index5 ) ) THEN   ;   iargidx = -1
815         ELSE                                ;   iargidx =  5   ;   iargval = index5
816         ENDIF
817      CASE ( 5 )
818         IF( .NOT. PRESENT(index6 ) ) THEN   ;   iargidx = -1
819         ELSE                                ;   iargidx =  6   ;   iargval = index6
820         ENDIF
821      CASE ( 6 )
822         IF( .NOT. PRESENT(index7 ) ) THEN   ;   iargidx = -1
823         ELSE                                ;   iargidx =  7   ;   iargval = index7
824         ENDIF
825      CASE ( 7 )
826         IF( .NOT. PRESENT(index8 ) ) THEN   ;   iargidx = -1
827         ELSE                                ;   iargidx =  8   ;   iargval = index8
828         ENDIF
829      CASE ( 8 )
830         IF( .NOT. PRESENT(index2 ) ) THEN   ;   iargidx = -1
831         ELSE                                ;   iargidx =  9   ;   iargval = index9
832         ENDIF
833      CASE ( 9 )
834         IF( .NOT. PRESENT(index10) ) THEN   ;   iargidx = -1
835         ELSE                                ;   iargidx = 10   ;   iargval = index10
836         ENDIF
837      CASE ( 10 )
838         IF( .NOT. PRESENT(index11) ) THEN   ;   iargidx = -1
839         ELSE                                ;   iargidx = 11   ;   iargval = index11
840         ENDIF
841      CASE ( 11 )
842         IF( .NOT. PRESENT(index12) ) THEN   ;   iargidx = -1
843         ELSE                                ;   iargidx = 12   ;   iargval = index12
844         ENDIF
845      CASE ( 12 )
846         IF( .NOT. PRESENT(index13) ) THEN   ;   iargidx = -1
847         ELSE                                ;   iargidx =  13   ;   iargval = index13
848         ENDIF
849      CASE ( 13 )
850         IF( .NOT. PRESENT(index14) ) THEN   ;   iargidx = -1
851         ELSE                                ;   iargidx = 14   ;   iargval = index14
852         ENDIF
853      CASE ( 14 )
854         IF( .NOT. PRESENT(index15) ) THEN   ;   iargidx = -1
855         ELSE                                ;   iargidx = 15   ;   iargval = index15
856         ENDIF
857      CASE ( 15 )
858         IF( .NOT. PRESENT(index16) ) THEN   ;   iargidx = -1
859         ELSE                                ;   iargidx = 16   ;   iargval = index16
860         ENDIF
861      CASE ( 16 )
862         IF( .NOT. PRESENT(index17) ) THEN   ;   iargidx = -1
863         ELSE                                ;   iargidx = 17   ;   iargval = index17
864         END IF
865      CASE ( 17 )
866         IF( .NOT. PRESENT(index18) ) THEN   ;   iargidx = -1
867         ELSE                                ;   iargidx = 18   ;   iargval = index18
868         ENDIF
869      CASE ( 18 )
870         IF( .NOT. PRESENT(index19) ) THEN   ;   iargidx = -1
871         ELSE                                ;   iargidx = 19   ;   iargval = index19
872         ENDIF
873      CASE ( 19 )
874         IF( .NOT. PRESENT(index20) ) THEN   ;   iargidx = -1
875         ELSE                                ;   iargidx = 20   ;   iargval = index20
876         ENDIF
877      CASE ( 20 )
878         IF( .NOT. PRESENT(index21) ) THEN   ;   iargidx = -1
879         ELSE                                ;   iargidx = 21   ;   iargval = index21
880         ENDIF
881      CASE ( 21 )
882         IF( .NOT. PRESENT(index22) ) THEN   ;   iargidx = -1
883         ELSE                                ;   iargidx = 22   ;   iargval = index22
884         ENDIF
885      CASE ( 22 )
886         IF( .NOT. PRESENT(index23) ) THEN   ;   iargidx = -1
887         ELSE                                ;   iargidx = 23   ;   iargval = index23
888         ENDIF
889      CASE ( 23 )
890         IF( .NOT. PRESENT(index24) ) THEN   ;   iargidx = -1
891         ELSE                                ;   iargidx = 24   ;   iargval = index24
892         ENDIF
893      CASE ( 24 )
894         IF( .NOT. PRESENT(index25) ) THEN   ;   iargidx = -1
895         ELSE                                ;   iargidx = 25   ;   iargval = index25
896         ENDIF
897      CASE ( 25 )
898         IF( .NOT. PRESENT(index26) ) THEN   ;   iargidx = -1
899         ELSE                                ;   iargidx = 26   ;   iargval = index26
900         ENDIF
901      CASE ( 26 )
902         IF( .NOT. PRESENT(index27) ) THEN   ;   iargidx = -1
903         ELSE                                ;   iargidx = 27   ;   iargval = index27
904         ENDIF
905      CASE ( 27 )
906         iargidx = -1
907      CASE DEFAULT
908         ! BUG - iargidx shouldn't take any other values!
909         ! Flag error for calling routine
910         iargidx = -99
911      END SELECT
912      !
913   END SUBROUTINE get_next_arg
914
915   !!=====================================================================
916END MODULE wrk_nemo
Note: See TracBrowser for help on using the repository browser.