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

source: trunk/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 2749

Last change on this file since 2749 was 2749, checked in by smasson, 13 years ago

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