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

Last change on this file since 2676 was 2676, checked in by rblod, 13 years ago

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