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

source: branches/UKMO/nemo_v3_6_STABLE_pkg/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 6254

Last change on this file since 6254 was 6254, checked in by frrh, 8 years ago

Merge branches/UKMO/dev_r5107_hadgem3_mct@5679 (not 5631 as used in
original GO6.1 which I was supplied with! This has extra, meaningful,
error trapping in place of the original inappropriate use of "STOP"
which is useless in the context of coupled models.

Again merging this branch proved far more awkward than it should
be with spurious claims of conflicts in various irrelevant files
in NEMOGCM/ARCH/ and DOC/TexFiles which I reverted before committing.
File size: 37.1 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         : get work space arrays
12   !!   wrk_dealloc       : release work space arrays
13   !!
14   !! 1d arrays:
15   !!   REAL(wp), POINTER, DIMENSION(:) :: arr1, arr2, ... arr10
16   !!    or
17   !!   INTEGER, POINTER, DIMENSION(:) :: arr1, arr2, ... arr10
18   !!   ...
19   !!   CALL wrk_alloc( nx, arr1, arr2, ... arr10, kistart = kistart )
20   !!   ...
21   !!   CALL wrk_dealloc( nx, arr1, arr2, ... arr10, kistart = kistart)
22   !!   with:
23   !!     - arr*: 1d arrays. real or (not and) integer
24   !!     - nx: size of the 1d arr* arrays
25   !!     - arr2, ..., arr10: optional parameters
26   !!     - kistart: optional parameter to lower bound of the 1st dimension (default = 1)
27   !!
28   !! 2d arrays:
29   !!   REAL(wp), POINTER, DIMENSION(:,:) :: arr1, arr2, ... arr10
30   !!    or
31   !!   INTEGER, POINTER, DIMENSION(:,:) :: arr1, arr2, ... arr10
32   !!   ...
33   !!   CALL wrk_alloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart )
34   !!   ...
35   !!   CALL wrk_dealloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart )
36   !!   with:
37   !!     - arr* 2d arrays. real or (not and) integer
38   !!     - nx, ny: size of the 2d arr* arrays
39   !!     - arr2, ..., arr10: optional parameters
40   !!     - kistart, kjstart: optional parameters to lower bound of the 1st/2nd dimension (default = 1)
41   !!
42   !! 3d arrays:
43   !!   REAL(wp), POINTER, DIMENSION(:,:,:) :: arr1, arr2, ... arr10
44   !!    or
45   !!   INTEGER, POINTER, DIMENSION(:,:,:) :: arr1, arr2, ... arr10
46   !!   ...
47   !!   CALL wrk_alloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart )
48   !!   ...
49   !!   CALL wrk_dealloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart )
50   !!   with:
51   !!     - arr* 3d arrays. real or (not and) integer
52   !!     - nx, ny, nz: size of the 3d arr* arrays
53   !!     - arr2, ..., arr10: optional parameters
54   !!     - kistart, kjstart, kkstart: optional parameters to lower bound of the 1st/2nd/3rd dimension (default = 1)
55   !!
56   !! 4d arrays:
57   !!   REAL(wp), POINTER, DIMENSION(:,:,:,:) :: arr1, arr2, ... arr10
58   !!    or
59   !!   INTEGER, POINTER, DIMENSION(:,:,:,:) :: arr1, arr2, ... arr10
60   !!   ...
61   !!   CALL wrk_alloc( nx, ny, nz, nl, arr1, arr2, ... arr10, &
62   !!      &            kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart )
63   !!   ...
64   !!   CALL wrk_dealloc( nx, ny, nz, nl, arr1, arr2, ... arr10, &
65   !!      &            kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart )
66   !!   with:
67   !!     - arr* 3d arrays. real or (not and) integer
68   !!     - nx, ny, nz, nl: size of the 4d arr* arrays
69   !!     - arr2, ..., arr10: optional parameters
70   !!     - kistart, kjstart, kkstart, klstart: optional parameters to lower bound of the 1st/2nd/3rd/4th dimension (default = 1)
71   !!   
72   !!----------------------------------------------------------------------
73   USE par_oce        ! ocean parameters
74   USE lib_mpp
75
76   IMPLICIT NONE
77   PRIVATE
78   
79   PUBLIC wrk_alloc, wrk_dealloc, wrk_list
80
81   INTERFACE wrk_alloc
82      MODULE PROCEDURE wrk_alloc_1dr, wrk_alloc_2dr, wrk_alloc_3dr, wrk_alloc_4dr,   &
83         &             wrk_alloc_1di, wrk_alloc_2di, wrk_alloc_3di, wrk_alloc_4di
84   END INTERFACE
85
86   INTERFACE wrk_dealloc
87      MODULE PROCEDURE wrk_dealloc_1dr, wrk_dealloc_2dr, wrk_dealloc_3dr, wrk_dealloc_4dr,   &
88         &             wrk_dealloc_1di, wrk_dealloc_2di, wrk_dealloc_3di, wrk_dealloc_4di
89   END INTERFACE
90
91
92   INTEGER, PARAMETER :: jparray = 1000
93   INTEGER, PARAMETER :: jpmaxdim = 4
94
95   INTEGER, PARAMETER :: jpnotdefined = 0
96   INTEGER, PARAMETER :: jpinteger = 1
97   INTEGER, PARAMETER :: jpreal = 2
98 
99   TYPE leaf
100      LOGICAL :: in_use
101      INTEGER :: indic
102      INTEGER , DIMENSION(:)      , POINTER :: iwrk1d => NULL()   
103      INTEGER , DIMENSION(:,:)    , POINTER :: iwrk2d => NULL()   
104      INTEGER , DIMENSION(:,:,:)  , POINTER :: iwrk3d => NULL()   
105      INTEGER , DIMENSION(:,:,:,:), POINTER :: iwrk4d => NULL()   
106      REAL(wp), DIMENSION(:)      , POINTER :: zwrk1d => NULL()   
107      REAL(wp), DIMENSION(:,:)    , POINTER :: zwrk2d => NULL()   
108      REAL(wp), DIMENSION(:,:,:)  , POINTER :: zwrk3d => NULL()   
109      REAL(wp), DIMENSION(:,:,:,:), POINTER :: zwrk4d => NULL()   
110      TYPE (leaf), POINTER :: next => NULL() 
111      TYPE (leaf), POINTER :: prev => NULL() 
112   END TYPE leaf
113   
114   TYPE branch
115      INTEGER :: itype
116      INTEGER, DIMENSION(jpmaxdim) :: ishape, istart
117      TYPE(leaf), POINTER :: start => NULL()     
118      TYPE(leaf), POINTER :: current => NULL()     
119   END TYPE branch
120
121   TYPE(branch), SAVE, DIMENSION(jparray) :: tree
122
123   LOGICAL ::   linit = .FALSE.
124   LOGICAL ::   ldebug = .FALSE.
125   !!----------------------------------------------------------------------
126   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
127   !! $Id$
128   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
129   !!----------------------------------------------------------------------
130CONTAINS
131
132   SUBROUTINE wrk_list
133      ! to list 3d arrays in use, to be duplicated for all cases
134      WRITE(*,*) 'Arrays in use :'
135      !      CALL listage(tree_3d(1)%s_wrk_3d_start)
136      WRITE(*,*) ''
137     
138   END SUBROUTINE wrk_list
139   
140   
141   RECURSIVE SUBROUTINE listage(ptr)
142     
143      TYPE(leaf), POINTER, INTENT(in) :: ptr
144      !
145      IF( ASSOCIATED(ptr%next) ) CALL listage(ptr%next)
146      WRITE(*,*) ptr%in_use, ptr%indic   
147     
148   END SUBROUTINE listage
149
150
151   SUBROUTINE wrk_alloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart )
152      INTEGER                        , INTENT(in   )           ::   kidim   ! dimensions size
153      REAL(wp), POINTER, DIMENSION(:), INTENT(inout)           ::   p1d01
154      REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL ::   p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
155      INTEGER                        , INTENT(in   ), OPTIONAL ::   kistart
156      !
157      CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1,                                            &
158         &               p1d01 = p1d01, p1d02 = p1d02, p1d03 = p1d03, p1d04 = p1d04, p1d05 = p1d05,   &
159         &               p1d06 = p1d06, p1d07 = p1d07, p1d08 = p1d08, p1d09 = p1d09, p1d10 = p1d10    )
160      !
161   END SUBROUTINE wrk_alloc_1dr
162
163
164   SUBROUTINE wrk_alloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart )
165      INTEGER                        , INTENT(in   )           ::   kidim   ! dimensions size
166      INTEGER , POINTER, DIMENSION(:), INTENT(inout)           ::   k1d01
167      INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL ::   k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
168      INTEGER                        , INTENT(in   ), OPTIONAL ::   kistart
169      !
170      CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1,                                            &
171         &               k1d01 = k1d01, k1d02 = k1d02, k1d03 = k1d03, k1d04 = k1d04, k1d05 = k1d05,   &
172         &               k1d06 = k1d06, k1d07 = k1d07, k1d08 = k1d08, k1d09 = k1d09, k1d10 = k1d10    )
173      !
174   END SUBROUTINE wrk_alloc_1di
175
176
177   SUBROUTINE wrk_alloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart, kjstart )
178      INTEGER                          , INTENT(in   )           ::   kidim, kjdim   ! dimensions size
179      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout)           ::   p2d01
180      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL ::   p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
181      INTEGER                          , INTENT(in   ), OPTIONAL ::   kistart, kjstart
182      !
183      CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1,                                  &
184         &               p2d01 = p2d01, p2d02 = p2d02, p2d03 = p2d03, p2d04 = p2d04, p2d05 = p2d05,   &
185         &               p2d06 = p2d06, p2d07 = p2d07, p2d08 = p2d08, p2d09 = p2d09, p2d10 = p2d10    )
186      !
187   END SUBROUTINE wrk_alloc_2dr
188
189
190   SUBROUTINE wrk_alloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart, kjstart )
191      INTEGER                          , INTENT(in   )           ::   kidim, kjdim   ! dimensions size
192      INTEGER , POINTER, DIMENSION(:,:), INTENT(inout)           ::   k2d01
193      INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL ::   k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
194      INTEGER                          , INTENT(in   ), OPTIONAL ::   kistart, kjstart
195      !
196      CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1,                                  &
197         &               k2d01 = k2d01, k2d02 = k2d02, k2d03 = k2d03, k2d04 = k2d04, k2d05 = k2d05,   &
198         &               k2d06 = k2d06, k2d07 = k2d07, k2d08 = k2d08, k2d09 = k2d09, k2d10 = k2d10    )
199      !
200   END SUBROUTINE wrk_alloc_2di
201
202
203   SUBROUTINE wrk_alloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10,   &
204      &                      kistart, kjstart, kkstart )
205      INTEGER                            , INTENT(in   )           ::   kidim, kjdim, kkdim   ! dimensions size
206      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout)           ::   p3d01
207      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL ::   p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
208      INTEGER                            , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart
209      !
210      CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1,                        &
211         &               p3d01 = p3d01, p3d02 = p3d02, p3d03 = p3d03, p3d04 = p3d04, p3d05 = p3d05,   &
212         &               p3d06 = p3d06, p3d07 = p3d07, p3d08 = p3d08, p3d09 = p3d09, p3d10 = p3d10    )
213      !
214   END SUBROUTINE wrk_alloc_3dr
215
216
217   SUBROUTINE wrk_alloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10,   &
218      &                      kistart, kjstart, kkstart )
219      INTEGER                            , INTENT(in   )           ::   kidim, kjdim, kkdim   ! dimensions size
220      INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout)           ::   k3d01
221      INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL ::   k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
222      INTEGER                            , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart
223      !
224      CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1,                        &
225         &               k3d01 = k3d01, k3d02 = k3d02, k3d03 = k3d03, k3d04 = k3d04, k3d05 = k3d05,   &
226         &               k3d06 = k3d06, k3d07 = k3d07, k3d08 = k3d08, k3d09 = k3d09, k3d10 = k3d10    )
227      !
228   END SUBROUTINE wrk_alloc_3di
229
230
231   SUBROUTINE wrk_alloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10,   &
232      &                      kistart, kjstart, kkstart, klstart )
233      INTEGER                              , INTENT(in   )           ::   kidim, kjdim, kkdim, kldim   ! dimensions size
234      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout)           ::   p4d01
235      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL ::   p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
236      INTEGER                              , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart, klstart
237      !
238      CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart,              &
239         &               p4d01 = p4d01, p4d02 = p4d02, p4d03 = p4d03, p4d04 = p4d04, p4d05 = p4d05,   &
240         &               p4d06 = p4d06, p4d07 = p4d07, p4d08 = p4d08, p4d09 = p4d09, p4d10 = p4d10    )
241      !
242   END SUBROUTINE wrk_alloc_4dr
243
244
245   SUBROUTINE wrk_alloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10,   &
246      &                      kistart, kjstart, kkstart, klstart )
247      INTEGER                              , INTENT(in   )           ::   kidim, kjdim, kkdim, kldim   ! dimensions size
248      INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout)           ::   k4d01
249      INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL ::   k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
250      INTEGER                              , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart, klstart
251      !
252      CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart,              &
253         &               k4d01 = k4d01, k4d02 = k4d02, k4d03 = k4d03, k4d04 = k4d04, k4d05 = k4d05,   &
254         &               k4d06 = k4d06, k4d07 = k4d07, k4d08 = k4d08, k4d09 = k4d09, k4d10 = k4d10    )
255      !
256   END SUBROUTINE wrk_alloc_4di
257
258
259   SUBROUTINE wrk_dealloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart )
260      INTEGER                        , INTENT(in   )           ::   kidim   ! dimensions size
261      REAL(wp), POINTER, DIMENSION(:), INTENT(inout)           ::   p1d01
262      REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL ::   p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
263      INTEGER                        , INTENT(in   ), OPTIONAL ::   kistart
264      !
265      INTEGER :: icnt, jn
266      icnt = 1 + COUNT( (/                PRESENT(p1d02),PRESENT(p1d03),PRESENT(p1d04),PRESENT(p1d05),   &
267         &                 PRESENT(p1d06),PRESENT(p1d07),PRESENT(p1d08),PRESENT(p1d09),PRESENT(p1d10) /) )
268      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpreal, kidim, 0, 0, 0, kistart, 1, 1, 1)   ;   END DO
269      !
270   END SUBROUTINE wrk_dealloc_1dr
271
272
273   SUBROUTINE wrk_dealloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart )
274      INTEGER                        , INTENT(in   )           ::   kidim   ! dimensions size
275      INTEGER , POINTER, DIMENSION(:), INTENT(inout)           ::   k1d01
276      INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL ::   k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
277      INTEGER                        , INTENT(in   ), OPTIONAL ::   kistart
278      !
279      INTEGER :: icnt, jn
280      icnt = 1 + COUNT( (/                PRESENT(k1d02),PRESENT(k1d03),PRESENT(k1d04),PRESENT(k1d05),   &
281         &                 PRESENT(k1d06),PRESENT(k1d07),PRESENT(k1d08),PRESENT(k1d09),PRESENT(k1d10) /) )
282      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpinteger, kidim, 0, 0, 0, kistart, 1, 1, 1 )   ;   END DO
283      !
284   END SUBROUTINE wrk_dealloc_1di
285
286
287   SUBROUTINE wrk_dealloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart,kjstart )
288      INTEGER                          , INTENT(in   )           ::   kidim, kjdim   ! dimensions size
289      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout)           ::   p2d01
290      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL ::   p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
291      INTEGER                          , INTENT(in   ), OPTIONAL ::   kistart, kjstart
292      !
293      INTEGER :: icnt, jn
294      icnt = 1 + COUNT( (/                PRESENT(p2d02),PRESENT(p2d03),PRESENT(p2d04),PRESENT(p2d05),   &
295         &                 PRESENT(p2d06),PRESENT(p2d07),PRESENT(p2d08),PRESENT(p2d09),PRESENT(p2d10) /) )
296      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpreal, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 )   ;   END DO
297      !
298   END SUBROUTINE wrk_dealloc_2dr
299
300
301   SUBROUTINE wrk_dealloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart,kjstart )
302      INTEGER                          , INTENT(in   )           ::   kidim, kjdim   ! dimensions size
303      INTEGER , POINTER, DIMENSION(:,:), INTENT(inout)           ::   k2d01
304      INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL ::   k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
305      INTEGER                          , INTENT(in   ), OPTIONAL ::   kistart, kjstart
306      !
307      INTEGER :: icnt, jn
308      icnt = 1 + COUNT( (/                PRESENT(k2d02),PRESENT(k2d03),PRESENT(k2d04),PRESENT(k2d05),   &
309         &                 PRESENT(k2d06),PRESENT(k2d07),PRESENT(k2d08),PRESENT(k2d09),PRESENT(k2d10) /) )
310      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpinteger, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 )   ;   END DO
311      !
312   END SUBROUTINE wrk_dealloc_2di
313
314
315   SUBROUTINE wrk_dealloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10,   &
316      &                        kistart, kjstart, kkstart )
317      INTEGER                            , INTENT(in   )           ::   kidim, kjdim, kkdim   ! dimensions size
318      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout)           ::   p3d01
319      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL ::   p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
320      INTEGER                            , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart
321      !
322      INTEGER :: icnt, jn
323      icnt = 1 + COUNT( (/                PRESENT(p3d02),PRESENT(p3d03),PRESENT(p3d04),PRESENT(p3d05),   &
324         &                 PRESENT(p3d06),PRESENT(p3d07),PRESENT(p3d08),PRESENT(p3d09),PRESENT(p3d10) /) )
325      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 )   ;   END DO
326      !
327   END SUBROUTINE wrk_dealloc_3dr
328
329
330   SUBROUTINE wrk_dealloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10,   &
331      &                        kistart, kjstart, kkstart )
332      INTEGER                            , INTENT(in   )           ::   kidim, kjdim, kkdim   ! dimensions size
333      INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout)           ::   k3d01
334      INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL ::   k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
335      INTEGER                            , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart
336      !
337      INTEGER :: icnt, jn
338      icnt = 1 + COUNT( (/                PRESENT(k3d02),PRESENT(k3d03),PRESENT(k3d04),PRESENT(k3d05),   &
339         &                 PRESENT(k3d06),PRESENT(k3d07),PRESENT(k3d08),PRESENT(k3d09),PRESENT(k3d10) /) )
340      DO jn = 1, icnt   ;   CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 )   ;   END DO
341      !
342   END SUBROUTINE wrk_dealloc_3di
343
344
345   SUBROUTINE wrk_dealloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10,   &
346      &                        kistart, kjstart, kkstart, klstart )
347      INTEGER                              , INTENT(in   )           ::   kidim, kjdim, kkdim, kldim   ! dimensions size
348      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout)           ::   p4d01
349      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL ::   p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
350      INTEGER                              , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart, klstart
351      !
352      INTEGER :: icnt, jn
353      icnt = 1 + COUNT( (/                PRESENT(p4d02),PRESENT(p4d03),PRESENT(p4d04),PRESENT(p4d05),   &
354         &                 PRESENT(p4d06),PRESENT(p4d07),PRESENT(p4d08),PRESENT(p4d09),PRESENT(p4d10) /) )
355      DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO
356      !
357   END SUBROUTINE wrk_dealloc_4dr
358
359
360   SUBROUTINE wrk_dealloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10,   &
361      &                        kistart, kjstart, kkstart, klstart )
362      INTEGER                              , INTENT(in   )           ::   kidim, kjdim, kkdim, kldim   ! dimensions size
363      INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout)           ::   k4d01
364      INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL ::   k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
365      INTEGER                              , INTENT(in   ), OPTIONAL ::   kistart, kjstart, kkstart, klstart
366      !
367      INTEGER :: icnt, jn
368      icnt = 1 + COUNT( (/                PRESENT(k4d02),PRESENT(k4d03),PRESENT(k4d04),PRESENT(k4d05),   &
369         &                 PRESENT(k4d06),PRESENT(k4d07),PRESENT(k4d08),PRESENT(k4d09),PRESENT(k4d10) /) )
370      DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO
371      !
372   END SUBROUTINE wrk_dealloc_4di
373
374
375   SUBROUTINE wrk_alloc_xd( kidim, kjdim, kkdim, kldim,                                             &
376      &                     kisrt, kjsrt, kksrt, klsrt,                                             &
377      &                     k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10,   &
378      &                     k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10,   &
379      &                     k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10,   &
380      &                     k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10,   &
381      &                     p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10,   &
382      &                     p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10,   &
383      &                     p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10,   &
384      &                     p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10    )
385      INTEGER                              ,INTENT(in   )         ::   kidim, kjdim, kkdim, kldim   ! dimensions size
386      INTEGER                              ,INTENT(in   ),OPTIONAL::   kisrt, kjsrt, kksrt, klsrt
387      INTEGER , POINTER, DIMENSION(:      ),INTENT(inout),OPTIONAL::   k1d01,k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
388      INTEGER , POINTER, DIMENSION(:,:    ),INTENT(inout),OPTIONAL::   k2d01,k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
389      INTEGER , POINTER, DIMENSION(:,:,:  ),INTENT(inout),OPTIONAL::   k3d01,k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
390      INTEGER , POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL::   k4d01,k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
391      REAL(wp), POINTER, DIMENSION(:      ),INTENT(inout),OPTIONAL::   p1d01,p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
392      REAL(wp), POINTER, DIMENSION(:,:    ),INTENT(inout),OPTIONAL::   p2d01,p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
393      REAL(wp), POINTER, DIMENSION(:,:,:  ),INTENT(inout),OPTIONAL::   p3d01,p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
394      REAL(wp), POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL::   p4d01,p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
395      !
396      LOGICAL ::   llpres
397      INTEGER ::   jn, iisrt, ijsrt, iksrt, ilsrt
398      !
399      IF( .NOT. linit ) THEN
400         tree(:)%itype = jpnotdefined
401         DO jn = 1, jparray   ;   tree(jn)%ishape(:) = 0   ;   tree(jn)%istart(:) = 0   ;   END DO
402         linit = .TRUE.
403      ENDIF
404
405      IF( PRESENT(kisrt) ) THEN   ;   iisrt =  kisrt   ;   ELSE   ;   iisrt = 1   ;   ENDIF
406      IF( PRESENT(kjsrt) ) THEN   ;   ijsrt =  kjsrt   ;   ELSE   ;   ijsrt = 1   ;   ENDIF
407      IF( PRESENT(kksrt) ) THEN   ;   iksrt =  kksrt   ;   ELSE   ;   iksrt = 1   ;   ENDIF
408      IF( PRESENT(klsrt) ) THEN   ;   ilsrt =  klsrt   ;   ELSE   ;   ilsrt = 1   ;   ENDIF
409
410      llpres =  PRESENT(k1d01) .OR. PRESENT(k2d01) .OR. PRESENT(k3d01) .OR. PRESENT(k4d01)   &
411         & .OR. PRESENT(p1d01) .OR. PRESENT(p2d01) .OR. PRESENT(p3d01) .OR. PRESENT(p4d01)
412      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
413         &                             k1d01, k2d01, k3d01, k4d01, p1d01, p2d01, p3d01, p4d01    )
414      llpres =  PRESENT(k1d02) .OR. PRESENT(k2d02) .OR. PRESENT(k3d02) .OR. PRESENT(k4d02)   &
415         & .OR. PRESENT(p1d02) .OR. PRESENT(p2d02) .OR. PRESENT(p3d02) .OR. PRESENT(p4d02)
416      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
417         &                             k1d02, k2d02, k3d02, k4d02, p1d02, p2d02, p3d02, p4d02    )
418      llpres =  PRESENT(k1d03) .OR. PRESENT(k2d03) .OR. PRESENT(k3d03) .OR. PRESENT(k4d03)   &
419         & .OR. PRESENT(p1d03) .OR. PRESENT(p2d03) .OR. PRESENT(p3d03) .OR. PRESENT(p4d03)
420      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
421         &                             k1d03, k2d03, k3d03, k4d03, p1d03, p2d03, p3d03, p4d03    )
422      llpres =  PRESENT(k1d04) .OR. PRESENT(k2d04) .OR. PRESENT(k3d04) .OR. PRESENT(k4d04)   &
423         & .OR. PRESENT(p1d04) .OR. PRESENT(p2d04) .OR. PRESENT(p3d04) .OR. PRESENT(p4d04)
424      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
425         &                             k1d04, k2d04, k3d04, k4d04, p1d04, p2d04, p3d04, p4d04    )
426      llpres =  PRESENT(k1d05) .OR. PRESENT(k2d05) .OR. PRESENT(k3d05) .OR. PRESENT(k4d05)   &
427         & .OR. PRESENT(p1d05) .OR. PRESENT(p2d05) .OR. PRESENT(p3d05) .OR. PRESENT(p4d05)
428      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
429         &                             k1d05, k2d05, k3d05, k4d05, p1d05, p2d05, p3d05, p4d05    )
430      llpres =  PRESENT(k1d06) .OR. PRESENT(k2d06) .OR. PRESENT(k3d06) .OR. PRESENT(k4d06)   &
431         & .OR. PRESENT(p1d06) .OR. PRESENT(p2d06) .OR. PRESENT(p3d06) .OR. PRESENT(p4d06)
432      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
433         &                             k1d06, k2d06, k3d06, k4d06, p1d06, p2d06, p3d06, p4d06    )
434      llpres =  PRESENT(k1d07) .OR. PRESENT(k2d07) .OR. PRESENT(k3d07) .OR. PRESENT(k4d07)   &
435         & .OR. PRESENT(p1d07) .OR. PRESENT(p2d07) .OR. PRESENT(p3d07) .OR. PRESENT(p4d07)
436      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
437         &                             k1d07, k2d07, k3d07, k4d07, p1d07, p2d07, p3d07, p4d07    )
438      llpres =  PRESENT(k1d08) .OR. PRESENT(k2d08) .OR. PRESENT(k3d08) .OR. PRESENT(k4d08)   &
439         & .OR. PRESENT(p1d08) .OR. PRESENT(p2d08) .OR. PRESENT(p3d08) .OR. PRESENT(p4d08)
440      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
441         &                             k1d08, k2d08, k3d08, k4d08, p1d08, p2d08, p3d08, p4d08    )
442      llpres =  PRESENT(k1d09) .OR. PRESENT(k2d09) .OR. PRESENT(k3d09) .OR. PRESENT(k4d09)   &
443         & .OR. PRESENT(p1d09) .OR. PRESENT(p2d09) .OR. PRESENT(p3d09) .OR. PRESENT(p4d09)
444      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
445         &                             k1d09, k2d09, k3d09, k4d09, p1d09, p2d09, p3d09, p4d09    )
446      llpres =  PRESENT(k1d10) .OR. PRESENT(k2d10) .OR. PRESENT(k3d10) .OR. PRESENT(k4d10)   &
447         & .OR. PRESENT(p1d10) .OR. PRESENT(p2d10) .OR. PRESENT(p3d10) .OR. PRESENT(p4d10)
448      IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt,   &
449         &                             k1d10, k2d10, k3d10, k4d10, p1d10, p2d10, p3d10, p4d10    )
450
451   END SUBROUTINE wrk_alloc_xd
452
453
454   SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt ,   &
455      &                      kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d    )
456      INTEGER                              , INTENT(in   )           :: kidim, kjdim, kkdim, kldim
457      INTEGER                              , INTENT(in   )           :: kisrt, kjsrt, kksrt, klsrt
458      INTEGER , POINTER, DIMENSION(:)      , INTENT(inout), OPTIONAL :: kwrk1d 
459      INTEGER , POINTER, DIMENSION(:,:)    , INTENT(inout), OPTIONAL :: kwrk2d 
460      INTEGER , POINTER, DIMENSION(:,:,:)  , INTENT(inout), OPTIONAL :: kwrk3d 
461      INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: kwrk4d 
462      REAL(wp), POINTER, DIMENSION(:)      , INTENT(inout), OPTIONAL :: pwrk1d 
463      REAL(wp), POINTER, DIMENSION(:,:)    , INTENT(inout), OPTIONAL :: pwrk2d 
464      REAL(wp), POINTER, DIMENSION(:,:,:)  , INTENT(inout), OPTIONAL :: pwrk3d 
465      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: pwrk4d 
466      !
467      INTEGER, DIMENSION(jpmaxdim) :: ishape, isrt, iend
468      INTEGER :: itype
469      INTEGER :: ii
470
471      ! define the shape to be given to the work array
472      ishape(:) = (/ kidim, kjdim, kkdim, kldim /)
473      ! define the starting index of the dimension shape to be given to the work array
474      isrt  (:) = (/ kisrt, kjsrt, kksrt, klsrt /)
475      iend  (:) = ishape(:) + isrt(:) - 1
476
477      ! is it integer or real array?
478      IF( PRESENT(kwrk1d) .OR. PRESENT(kwrk2d) .OR. PRESENT(kwrk3d) .OR. PRESENT(kwrk4d) )   itype = jpinteger   
479      IF( PRESENT(pwrk1d) .OR. PRESENT(pwrk2d) .OR. PRESENT(pwrk3d) .OR. PRESENT(pwrk4d) )   itype = jpreal         
480
481      ! find the branch with the matching shape, staring index and type or get the first "free" branch
482      ii = 1                         
483      DO WHILE(       ( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= isrt ) .OR. tree(ii)%itype /= itype )   &
484         &      .AND. SUM( tree(ii)%ishape ) /= 0 )
485         ii = ii + 1
486         IF (ii > jparray) CALL ctl_stop('STOP', 'NEMO aborted wrk_allocbase')
487                           ! increase the value of jparray (should not be needed as already very big!)
488      END DO
489     
490      IF( SUM( tree(ii)%ishape ) == 0 ) THEN                    ! create a new branch
491         IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype
492         tree(ii)%itype = itype                                        ! define the type of this branch
493         tree(ii)%ishape(:) = ishape(:)                                ! define the shape of this branch
494         tree(ii)%istart(:) = isrt(:)                                  ! define the lower bounds of this branch
495         ALLOCATE( tree(ii)%start )                                    ! allocate its start
496         ALLOCATE( tree(ii)%current)                                   ! allocate the current leaf (the first leaf)
497
498         tree(ii)%start%in_use = .FALSE.                               ! Never use the start as work array
499         tree(ii)%start%indic = 0
500         tree(ii)%start%prev => NULL()                                 ! nothing before the start
501         tree(ii)%start%next => tree(ii)%current                       ! first leaf link to the start
502         
503         tree(ii)%current%in_use = .FALSE.                             ! first leaf is not yet used
504         tree(ii)%current%indic = 1                                    ! first leaf
505         tree(ii)%current%prev => tree(ii)%start                       ! previous leaf is the start
506         tree(ii)%current%next => NULL()                               ! next leaf is not yet defined
507         ! allocate the array of the first leaf
508         IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1)                                                ) )
509         IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2)                                ) )
510         IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3)                ) )
511         IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
512         IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1)                                                ) )
513         IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2)                                ) )
514         IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3)                ) )
515         IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
516                 
517      ELSE IF( .NOT. ASSOCIATED(tree(ii)%current%next) ) THEN   ! all leafs used -> define a new one
518         ALLOCATE( tree(ii)%current%next )                             ! allocate the new leaf
519         tree(ii)%current%next%in_use = .FALSE.                        ! this leaf is not yet used
520         tree(ii)%current%next%indic = tree(ii)%current%indic + 1      ! number of this leaf
521         IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic
522         tree(ii)%current%next%prev => tree(ii)%current                ! previous leaf of the new leaf is the current leaf
523         tree(ii)%current%next%next => NULL()                          ! next leaf is not yet defined
524
525         tree(ii)%current => tree(ii)%current%next                     ! the current leaf becomes the new one
526 
527         ! allocate the array of the new leaf
528         IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1)                                                ) )
529         IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2)                                ) )
530         IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3)                ) )
531         IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
532         IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1)                                                ) )
533         IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2)                                ) )
534         IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3)                ) )
535         IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
536         
537      ELSE
538         tree(ii)%current => tree(ii)%current%next                     ! the current leaf becomes the next one
539      ENDIF   
540      !       
541      ! use the array of the current leaf as a work array
542      IF( PRESENT(kwrk1d) ) kwrk1d => tree(ii)%current%iwrk1d   
543      IF( PRESENT(kwrk2d) ) kwrk2d => tree(ii)%current%iwrk2d   
544      IF( PRESENT(kwrk3d) ) kwrk3d => tree(ii)%current%iwrk3d   
545      IF( PRESENT(kwrk4d) ) kwrk4d => tree(ii)%current%iwrk4d   
546      IF( PRESENT(pwrk1d) ) pwrk1d => tree(ii)%current%zwrk1d   
547      IF( PRESENT(pwrk2d) ) pwrk2d => tree(ii)%current%zwrk2d   
548      IF( PRESENT(pwrk3d) ) pwrk3d => tree(ii)%current%zwrk3d   
549      IF( PRESENT(pwrk4d) ) pwrk4d => tree(ii)%current%zwrk4d   
550      tree(ii)%current%in_use = .TRUE.   ! this leaf is now used
551      !     
552   END SUBROUTINE wrk_allocbase
553
554
555   SUBROUTINE wrk_deallocbase( ktype, kidim, kjdim, kkdim, kldim, kisrt, kjsrt, kksrt, klsrt )
556      INTEGER, INTENT(in   )           :: ktype
557      INTEGER, INTENT(in   )           :: kidim, kjdim, kkdim, kldim
558      INTEGER, INTENT(in   ), OPTIONAL :: kisrt, kjsrt, kksrt, klsrt
559      !
560      INTEGER, DIMENSION(jpmaxdim) :: ishape, istart
561      INTEGER :: ii
562
563      ishape(:) = (/ kidim, kjdim, kkdim, kldim /)
564      IF( PRESENT(kisrt) ) THEN   ;   istart(1) =  kisrt   ;   ELSE   ;   istart(1) = 1   ;   ENDIF
565      IF( PRESENT(kjsrt) ) THEN   ;   istart(2) =  kjsrt   ;   ELSE   ;   istart(2) = 1   ;   ENDIF
566      IF( PRESENT(kksrt) ) THEN   ;   istart(3) =  kksrt   ;   ELSE   ;   istart(3) = 1   ;   ENDIF
567      IF( PRESENT(klsrt) ) THEN   ;   istart(4) =  klsrt   ;   ELSE   ;   istart(4) = 1   ;   ENDIF 
568
569      ! find the branch with the matcing shape and type or get the first "free" branch
570      ii = 1                         
571      DO WHILE( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= istart ) .OR. tree(ii)%itype /= ktype )
572         ii = ii + 1
573      END DO
574      !
575      tree(ii)%current%in_use = .FALSE.           ! current leaf is no more used
576      tree(ii)%current => tree(ii)%current%prev   ! move back toward previous leaf   
577      !
578   END SUBROUTINE wrk_deallocbase
579
580
581   SUBROUTINE wrk_stop(cmsg)
582      !!----------------------------------------------------------------------
583      !!               ***  ROUTINE wrk_stop  ***
584      !! ** Purpose :   to act as local alternative to ctl_stop.
585      !!                Avoids dependency on in_out_manager module.
586      !!----------------------------------------------------------------------
587      CHARACTER(LEN=*), INTENT(in) :: cmsg
588      !!----------------------------------------------------------------------
589      !
590!      WRITE(kumout, cform_err2)
591      WRITE(*,*) TRIM(cmsg)
592      ! ARPDBG - would like to CALL mppstop here to force a stop but that
593      ! introduces a dependency on lib_mpp. Could CALL mpi_abort() directly
594      ! but that's fairly brutal. Better to rely on CALLing routine to
595      ! deal with the error passed back from the wrk_X routine?
596      !CALL mppstop
597      !
598   END SUBROUTINE wrk_stop
599
600   !!=====================================================================
601END MODULE wrk_nemo
Note: See TracBrowser for help on using the repository browser.