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

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

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