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

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 4409

Last change on this file since 4409 was 3432, checked in by trackstand2, 12 years ago

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