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/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 2789

Last change on this file since 2789 was 2789, checked in by cetlod, 13 years ago

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