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

source: branches/UKMO/dev_r5107_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 5679

Last change on this file since 5679 was 5679, checked in by dancopsey, 9 years ago

Merged in extra clean shutdown stuff so that it stops with an error when NEMO crashes rather than carrying on.
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.