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

source: branches/UKMO/dev_r5518_GC3_couple_pkg/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90 @ 7985

Last change on this file since 7985 was 7985, checked in by frrh, 7 years ago

Met Office GMED ticket 322 refers.
Apply updates the Met Office GC3 coupled package branch in order to
accommodate developments under GMED ticket 320 which insert long
standing missing revisions of the nemo_v3_6_STABLE branch
to the Met Office GO6 package branch.

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