Context Navigation

wrk_nemo.F90

Last change on this file was 11738, checked in by marc, 5 years ago
The Dr Hook changes from my perl code.
File size: 44.5 KB

Line
1	MODULE 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	USE yomhook, ONLY: lhook, dr_hook
76	USE parkind1, ONLY: jprb, jpim
77
78	IMPLICIT NONE
79	PRIVATE
80
81	PUBLIC wrk_alloc, wrk_dealloc, wrk_list
82
83	INTERFACE wrk_alloc
84	MODULE PROCEDURE wrk_alloc_1dr, wrk_alloc_2dr, wrk_alloc_3dr, wrk_alloc_4dr, &
85	& wrk_alloc_1di, wrk_alloc_2di, wrk_alloc_3di, wrk_alloc_4di
86	END INTERFACE
87
88	INTERFACE wrk_dealloc
89	MODULE PROCEDURE wrk_dealloc_1dr, wrk_dealloc_2dr, wrk_dealloc_3dr, wrk_dealloc_4dr, &
90	& wrk_dealloc_1di, wrk_dealloc_2di, wrk_dealloc_3di, wrk_dealloc_4di
91	END INTERFACE
92
93
94	INTEGER, PARAMETER :: jparray = 1000
95	INTEGER, PARAMETER :: jpmaxdim = 4
96
97	INTEGER, PARAMETER :: jpnotdefined = 0
98	INTEGER, PARAMETER :: jpinteger = 1
99	INTEGER, PARAMETER :: jpreal = 2
100
101	TYPE leaf
102	LOGICAL :: in_use
103	INTEGER :: indic
104	INTEGER , DIMENSION(:) , POINTER :: iwrk1d => NULL()
105	INTEGER , DIMENSION(:,:) , POINTER :: iwrk2d => NULL()
106	INTEGER , DIMENSION(:,:,:) , POINTER :: iwrk3d => NULL()
107	INTEGER , DIMENSION(:,:,:,:), POINTER :: iwrk4d => NULL()
108	REAL(wp), DIMENSION(:) , POINTER :: zwrk1d => NULL()
109	REAL(wp), DIMENSION(:,:) , POINTER :: zwrk2d => NULL()
110	REAL(wp), DIMENSION(:,:,:) , POINTER :: zwrk3d => NULL()
111	REAL(wp), DIMENSION(:,:,:,:), POINTER :: zwrk4d => NULL()
112	TYPE (leaf), POINTER :: next => NULL()
113	TYPE (leaf), POINTER :: prev => NULL()
114	END TYPE leaf
115
116	TYPE branch
117	INTEGER :: itype
118	INTEGER, DIMENSION(jpmaxdim) :: ishape, istart
119	TYPE(leaf), POINTER :: start => NULL()
120	TYPE(leaf), POINTER :: current => NULL()
121	END TYPE branch
122
123	TYPE(branch), SAVE, DIMENSION(jparray) :: tree
124
125	LOGICAL :: linit = .FALSE.
126	LOGICAL :: ldebug = .FALSE.
127	!!----------------------------------------------------------------------
128	!! NEMO/OPA 4.0 , NEMO Consortium (2011)
129	!! $Id$
130	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
131	!!----------------------------------------------------------------------
132	CONTAINS
133
134	SUBROUTINE wrk_list
135	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
136	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
137	REAL(KIND=jprb) :: zhook_handle
138
139	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_LIST'
140
141	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
142
143	! to list 3d arrays in use, to be duplicated for all cases
144	WRITE(,) 'Arrays in use :'
145	! CALL listage(tree_3d(1)%s_wrk_3d_start)
146	WRITE(,) ''
147
148	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
149	END SUBROUTINE wrk_list
150
151
152	RECURSIVE SUBROUTINE listage(ptr)
153
154	TYPE(leaf), POINTER, INTENT(in) :: ptr
155	!
156	IF( ASSOCIATED(ptr%next) ) CALL listage(ptr%next)
157	WRITE(,) ptr%in_use, ptr%indic
158
159	END SUBROUTINE listage
160
161
162	SUBROUTINE wrk_alloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart )
163	INTEGER , INTENT(in ) :: kidim ! dimensions size
164	REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01
165	REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
166	INTEGER , INTENT(in ), OPTIONAL :: kistart
167	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
168	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
169	REAL(KIND=jprb) :: zhook_handle
170
171	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_1DR'
172
173	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
174
175	!
176	CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, &
177	& p1d01 = p1d01, p1d02 = p1d02, p1d03 = p1d03, p1d04 = p1d04, p1d05 = p1d05, &
178	& p1d06 = p1d06, p1d07 = p1d07, p1d08 = p1d08, p1d09 = p1d09, p1d10 = p1d10 )
179	!
180	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
181	END SUBROUTINE wrk_alloc_1dr
182
183
184	SUBROUTINE wrk_alloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart )
185	INTEGER , INTENT(in ) :: kidim ! dimensions size
186	INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01
187	INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
188	INTEGER , INTENT(in ), OPTIONAL :: kistart
189	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
190	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
191	REAL(KIND=jprb) :: zhook_handle
192
193	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_1DI'
194
195	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
196
197	!
198	CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, &
199	& k1d01 = k1d01, k1d02 = k1d02, k1d03 = k1d03, k1d04 = k1d04, k1d05 = k1d05, &
200	& k1d06 = k1d06, k1d07 = k1d07, k1d08 = k1d08, k1d09 = k1d09, k1d10 = k1d10 )
201	!
202	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
203	END SUBROUTINE wrk_alloc_1di
204
205
206	SUBROUTINE wrk_alloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart, kjstart )
207	INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size
208	REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01
209	REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
210	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart
211	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
212	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
213	REAL(KIND=jprb) :: zhook_handle
214
215	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_2DR'
216
217	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
218
219	!
220	CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, &
221	& p2d01 = p2d01, p2d02 = p2d02, p2d03 = p2d03, p2d04 = p2d04, p2d05 = p2d05, &
222	& p2d06 = p2d06, p2d07 = p2d07, p2d08 = p2d08, p2d09 = p2d09, p2d10 = p2d10 )
223	!
224	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
225	END SUBROUTINE wrk_alloc_2dr
226
227
228	SUBROUTINE wrk_alloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart, kjstart )
229	INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size
230	INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01
231	INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
232	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart
233	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
234	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
235	REAL(KIND=jprb) :: zhook_handle
236
237	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_2DI'
238
239	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
240
241	!
242	CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, &
243	& k2d01 = k2d01, k2d02 = k2d02, k2d03 = k2d03, k2d04 = k2d04, k2d05 = k2d05, &
244	& k2d06 = k2d06, k2d07 = k2d07, k2d08 = k2d08, k2d09 = k2d09, k2d10 = k2d10 )
245	!
246	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
247	END SUBROUTINE wrk_alloc_2di
248
249
250	SUBROUTINE wrk_alloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, &
251	& kistart, kjstart, kkstart )
252	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size
253	REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01
254	REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
255	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart
256	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
257	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
258	REAL(KIND=jprb) :: zhook_handle
259
260	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_3DR'
261
262	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
263
264	!
265	CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, &
266	& p3d01 = p3d01, p3d02 = p3d02, p3d03 = p3d03, p3d04 = p3d04, p3d05 = p3d05, &
267	& p3d06 = p3d06, p3d07 = p3d07, p3d08 = p3d08, p3d09 = p3d09, p3d10 = p3d10 )
268	!
269	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
270	END SUBROUTINE wrk_alloc_3dr
271
272
273	SUBROUTINE wrk_alloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, &
274	& kistart, kjstart, kkstart )
275	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size
276	INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01
277	INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
278	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart
279	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
280	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
281	REAL(KIND=jprb) :: zhook_handle
282
283	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_3DI'
284
285	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
286
287	!
288	CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, &
289	& k3d01 = k3d01, k3d02 = k3d02, k3d03 = k3d03, k3d04 = k3d04, k3d05 = k3d05, &
290	& k3d06 = k3d06, k3d07 = k3d07, k3d08 = k3d08, k3d09 = k3d09, k3d10 = k3d10 )
291	!
292	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
293	END SUBROUTINE wrk_alloc_3di
294
295
296	SUBROUTINE wrk_alloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, &
297	& kistart, kjstart, kkstart, klstart )
298	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size
299	REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01
300	REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
301	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart
302	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
303	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
304	REAL(KIND=jprb) :: zhook_handle
305
306	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_4DR'
307
308	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
309
310	!
311	CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, &
312	& p4d01 = p4d01, p4d02 = p4d02, p4d03 = p4d03, p4d04 = p4d04, p4d05 = p4d05, &
313	& p4d06 = p4d06, p4d07 = p4d07, p4d08 = p4d08, p4d09 = p4d09, p4d10 = p4d10 )
314	!
315	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
316	END SUBROUTINE wrk_alloc_4dr
317
318
319	SUBROUTINE wrk_alloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, &
320	& kistart, kjstart, kkstart, klstart )
321	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size
322	INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01
323	INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
324	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart
325	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
326	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
327	REAL(KIND=jprb) :: zhook_handle
328
329	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_4DI'
330
331	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
332
333	!
334	CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, &
335	& k4d01 = k4d01, k4d02 = k4d02, k4d03 = k4d03, k4d04 = k4d04, k4d05 = k4d05, &
336	& k4d06 = k4d06, k4d07 = k4d07, k4d08 = k4d08, k4d09 = k4d09, k4d10 = k4d10 )
337	!
338	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
339	END SUBROUTINE wrk_alloc_4di
340
341
342	SUBROUTINE wrk_dealloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart )
343	INTEGER , INTENT(in ) :: kidim ! dimensions size
344	REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01
345	REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
346	INTEGER , INTENT(in ), OPTIONAL :: kistart
347	!
348	INTEGER :: icnt, jn
349	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
350	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
351	REAL(KIND=jprb) :: zhook_handle
352
353	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_1DR'
354
355	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
356
357	icnt = 1 + COUNT( (/ PRESENT(p1d02),PRESENT(p1d03),PRESENT(p1d04),PRESENT(p1d05), &
358	& PRESENT(p1d06),PRESENT(p1d07),PRESENT(p1d08),PRESENT(p1d09),PRESENT(p1d10) /) )
359	DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, 0, 0, 0, kistart, 1, 1, 1) ; END DO
360	!
361	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
362	END SUBROUTINE wrk_dealloc_1dr
363
364
365	SUBROUTINE wrk_dealloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart )
366	INTEGER , INTENT(in ) :: kidim ! dimensions size
367	INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01
368	INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
369	INTEGER , INTENT(in ), OPTIONAL :: kistart
370	!
371	INTEGER :: icnt, jn
372	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
373	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
374	REAL(KIND=jprb) :: zhook_handle
375
376	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_1DI'
377
378	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
379
380	icnt = 1 + COUNT( (/ PRESENT(k1d02),PRESENT(k1d03),PRESENT(k1d04),PRESENT(k1d05), &
381	& PRESENT(k1d06),PRESENT(k1d07),PRESENT(k1d08),PRESENT(k1d09),PRESENT(k1d10) /) )
382	DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, 0, 0, 0, kistart, 1, 1, 1 ) ; END DO
383	!
384	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
385	END SUBROUTINE wrk_dealloc_1di
386
387
388	SUBROUTINE wrk_dealloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart,kjstart )
389	INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size
390	REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01
391	REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
392	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart
393	!
394	INTEGER :: icnt, jn
395	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
396	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
397	REAL(KIND=jprb) :: zhook_handle
398
399	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_2DR'
400
401	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
402
403	icnt = 1 + COUNT( (/ PRESENT(p2d02),PRESENT(p2d03),PRESENT(p2d04),PRESENT(p2d05), &
404	& PRESENT(p2d06),PRESENT(p2d07),PRESENT(p2d08),PRESENT(p2d09),PRESENT(p2d10) /) )
405	DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO
406	!
407	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
408	END SUBROUTINE wrk_dealloc_2dr
409
410
411	SUBROUTINE wrk_dealloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart,kjstart )
412	INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size
413	INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01
414	INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
415	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart
416	!
417	INTEGER :: icnt, jn
418	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
419	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
420	REAL(KIND=jprb) :: zhook_handle
421
422	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_2DI'
423
424	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
425
426	icnt = 1 + COUNT( (/ PRESENT(k2d02),PRESENT(k2d03),PRESENT(k2d04),PRESENT(k2d05), &
427	& PRESENT(k2d06),PRESENT(k2d07),PRESENT(k2d08),PRESENT(k2d09),PRESENT(k2d10) /) )
428	DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO
429	!
430	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
431	END SUBROUTINE wrk_dealloc_2di
432
433
434	SUBROUTINE wrk_dealloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, &
435	& kistart, kjstart, kkstart )
436	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size
437	REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01
438	REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
439	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart
440	!
441	INTEGER :: icnt, jn
442	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
443	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
444	REAL(KIND=jprb) :: zhook_handle
445
446	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_3DR'
447
448	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
449
450	icnt = 1 + COUNT( (/ PRESENT(p3d02),PRESENT(p3d03),PRESENT(p3d04),PRESENT(p3d05), &
451	& PRESENT(p3d06),PRESENT(p3d07),PRESENT(p3d08),PRESENT(p3d09),PRESENT(p3d10) /) )
452	DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO
453	!
454	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
455	END SUBROUTINE wrk_dealloc_3dr
456
457
458	SUBROUTINE wrk_dealloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, &
459	& kistart, kjstart, kkstart )
460	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size
461	INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01
462	INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
463	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart
464	!
465	INTEGER :: icnt, jn
466	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
467	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
468	REAL(KIND=jprb) :: zhook_handle
469
470	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_3DI'
471
472	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
473
474	icnt = 1 + COUNT( (/ PRESENT(k3d02),PRESENT(k3d03),PRESENT(k3d04),PRESENT(k3d05), &
475	& PRESENT(k3d06),PRESENT(k3d07),PRESENT(k3d08),PRESENT(k3d09),PRESENT(k3d10) /) )
476	DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO
477	!
478	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
479	END SUBROUTINE wrk_dealloc_3di
480
481
482	SUBROUTINE wrk_dealloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, &
483	& kistart, kjstart, kkstart, klstart )
484	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size
485	REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01
486	REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
487	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart
488	!
489	INTEGER :: icnt, jn
490	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
491	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
492	REAL(KIND=jprb) :: zhook_handle
493
494	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_4DR'
495
496	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
497
498	icnt = 1 + COUNT( (/ PRESENT(p4d02),PRESENT(p4d03),PRESENT(p4d04),PRESENT(p4d05), &
499	& PRESENT(p4d06),PRESENT(p4d07),PRESENT(p4d08),PRESENT(p4d09),PRESENT(p4d10) /) )
500	DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO
501	!
502	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
503	END SUBROUTINE wrk_dealloc_4dr
504
505
506	SUBROUTINE wrk_dealloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, &
507	& kistart, kjstart, kkstart, klstart )
508	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size
509	INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01
510	INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
511	INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart
512	!
513	INTEGER :: icnt, jn
514	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
515	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
516	REAL(KIND=jprb) :: zhook_handle
517
518	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOC_4DI'
519
520	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
521
522	icnt = 1 + COUNT( (/ PRESENT(k4d02),PRESENT(k4d03),PRESENT(k4d04),PRESENT(k4d05), &
523	& PRESENT(k4d06),PRESENT(k4d07),PRESENT(k4d08),PRESENT(k4d09),PRESENT(k4d10) /) )
524	DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO
525	!
526	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
527	END SUBROUTINE wrk_dealloc_4di
528
529
530	SUBROUTINE wrk_alloc_xd( kidim, kjdim, kkdim, kldim, &
531	& kisrt, kjsrt, kksrt, klsrt, &
532	& k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, &
533	& k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, &
534	& k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, &
535	& k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, &
536	& p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, &
537	& p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, &
538	& p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, &
539	& p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10 )
540	INTEGER ,INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size
541	INTEGER ,INTENT(in ),OPTIONAL:: kisrt, kjsrt, kksrt, klsrt
542	INTEGER , POINTER, DIMENSION(: ),INTENT(inout),OPTIONAL:: k1d01,k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10
543	INTEGER , POINTER, DIMENSION(:,: ),INTENT(inout),OPTIONAL:: k2d01,k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10
544	INTEGER , POINTER, DIMENSION(:,:,: ),INTENT(inout),OPTIONAL:: k3d01,k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10
545	INTEGER , POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL:: k4d01,k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10
546	REAL(wp), POINTER, DIMENSION(: ),INTENT(inout),OPTIONAL:: p1d01,p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10
547	REAL(wp), POINTER, DIMENSION(:,: ),INTENT(inout),OPTIONAL:: p2d01,p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10
548	REAL(wp), POINTER, DIMENSION(:,:,: ),INTENT(inout),OPTIONAL:: p3d01,p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10
549	REAL(wp), POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL:: p4d01,p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10
550	!
551	LOGICAL :: llpres
552	INTEGER :: jn, iisrt, ijsrt, iksrt, ilsrt
553	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
554	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
555	REAL(KIND=jprb) :: zhook_handle
556
557	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOC_XD'
558
559	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
560
561	!
562	IF( .NOT. linit ) THEN
563	tree(:)%itype = jpnotdefined
564	DO jn = 1, jparray ; tree(jn)%ishape(:) = 0 ; tree(jn)%istart(:) = 0 ; END DO
565	linit = .TRUE.
566	ENDIF
567
568	IF( PRESENT(kisrt) ) THEN ; iisrt = kisrt ; ELSE ; iisrt = 1 ; ENDIF
569	IF( PRESENT(kjsrt) ) THEN ; ijsrt = kjsrt ; ELSE ; ijsrt = 1 ; ENDIF
570	IF( PRESENT(kksrt) ) THEN ; iksrt = kksrt ; ELSE ; iksrt = 1 ; ENDIF
571	IF( PRESENT(klsrt) ) THEN ; ilsrt = klsrt ; ELSE ; ilsrt = 1 ; ENDIF
572
573	llpres = PRESENT(k1d01) .OR. PRESENT(k2d01) .OR. PRESENT(k3d01) .OR. PRESENT(k4d01) &
574	& .OR. PRESENT(p1d01) .OR. PRESENT(p2d01) .OR. PRESENT(p3d01) .OR. PRESENT(p4d01)
575	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
576	& k1d01, k2d01, k3d01, k4d01, p1d01, p2d01, p3d01, p4d01 )
577	llpres = PRESENT(k1d02) .OR. PRESENT(k2d02) .OR. PRESENT(k3d02) .OR. PRESENT(k4d02) &
578	& .OR. PRESENT(p1d02) .OR. PRESENT(p2d02) .OR. PRESENT(p3d02) .OR. PRESENT(p4d02)
579	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
580	& k1d02, k2d02, k3d02, k4d02, p1d02, p2d02, p3d02, p4d02 )
581	llpres = PRESENT(k1d03) .OR. PRESENT(k2d03) .OR. PRESENT(k3d03) .OR. PRESENT(k4d03) &
582	& .OR. PRESENT(p1d03) .OR. PRESENT(p2d03) .OR. PRESENT(p3d03) .OR. PRESENT(p4d03)
583	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
584	& k1d03, k2d03, k3d03, k4d03, p1d03, p2d03, p3d03, p4d03 )
585	llpres = PRESENT(k1d04) .OR. PRESENT(k2d04) .OR. PRESENT(k3d04) .OR. PRESENT(k4d04) &
586	& .OR. PRESENT(p1d04) .OR. PRESENT(p2d04) .OR. PRESENT(p3d04) .OR. PRESENT(p4d04)
587	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
588	& k1d04, k2d04, k3d04, k4d04, p1d04, p2d04, p3d04, p4d04 )
589	llpres = PRESENT(k1d05) .OR. PRESENT(k2d05) .OR. PRESENT(k3d05) .OR. PRESENT(k4d05) &
590	& .OR. PRESENT(p1d05) .OR. PRESENT(p2d05) .OR. PRESENT(p3d05) .OR. PRESENT(p4d05)
591	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
592	& k1d05, k2d05, k3d05, k4d05, p1d05, p2d05, p3d05, p4d05 )
593	llpres = PRESENT(k1d06) .OR. PRESENT(k2d06) .OR. PRESENT(k3d06) .OR. PRESENT(k4d06) &
594	& .OR. PRESENT(p1d06) .OR. PRESENT(p2d06) .OR. PRESENT(p3d06) .OR. PRESENT(p4d06)
595	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
596	& k1d06, k2d06, k3d06, k4d06, p1d06, p2d06, p3d06, p4d06 )
597	llpres = PRESENT(k1d07) .OR. PRESENT(k2d07) .OR. PRESENT(k3d07) .OR. PRESENT(k4d07) &
598	& .OR. PRESENT(p1d07) .OR. PRESENT(p2d07) .OR. PRESENT(p3d07) .OR. PRESENT(p4d07)
599	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
600	& k1d07, k2d07, k3d07, k4d07, p1d07, p2d07, p3d07, p4d07 )
601	llpres = PRESENT(k1d08) .OR. PRESENT(k2d08) .OR. PRESENT(k3d08) .OR. PRESENT(k4d08) &
602	& .OR. PRESENT(p1d08) .OR. PRESENT(p2d08) .OR. PRESENT(p3d08) .OR. PRESENT(p4d08)
603	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
604	& k1d08, k2d08, k3d08, k4d08, p1d08, p2d08, p3d08, p4d08 )
605	llpres = PRESENT(k1d09) .OR. PRESENT(k2d09) .OR. PRESENT(k3d09) .OR. PRESENT(k4d09) &
606	& .OR. PRESENT(p1d09) .OR. PRESENT(p2d09) .OR. PRESENT(p3d09) .OR. PRESENT(p4d09)
607	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
608	& k1d09, k2d09, k3d09, k4d09, p1d09, p2d09, p3d09, p4d09 )
609	llpres = PRESENT(k1d10) .OR. PRESENT(k2d10) .OR. PRESENT(k3d10) .OR. PRESENT(k4d10) &
610	& .OR. PRESENT(p1d10) .OR. PRESENT(p2d10) .OR. PRESENT(p3d10) .OR. PRESENT(p4d10)
611	IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, &
612	& k1d10, k2d10, k3d10, k4d10, p1d10, p2d10, p3d10, p4d10 )
613
614	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
615	END SUBROUTINE wrk_alloc_xd
616
617
618	SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt , &
619	& kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d )
620	USE in_out_manager, ONLY: numout
621	INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim
622	INTEGER , INTENT(in ) :: kisrt, kjsrt, kksrt, klsrt
623	INTEGER , POINTER, DIMENSION(:) , INTENT(inout), OPTIONAL :: kwrk1d
624	INTEGER , POINTER, DIMENSION(:,:) , INTENT(inout), OPTIONAL :: kwrk2d
625	INTEGER , POINTER, DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: kwrk3d
626	INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: kwrk4d
627	REAL(wp), POINTER, DIMENSION(:) , INTENT(inout), OPTIONAL :: pwrk1d
628	REAL(wp), POINTER, DIMENSION(:,:) , INTENT(inout), OPTIONAL :: pwrk2d
629	REAL(wp), POINTER, DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: pwrk3d
630	REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: pwrk4d
631	!
632	INTEGER, DIMENSION(jpmaxdim) :: ishape, isrt, iend
633	INTEGER :: itype
634	INTEGER :: ii
635	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
636	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
637	REAL(KIND=jprb) :: zhook_handle
638
639	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_ALLOCBASE'
640
641	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
642
643
644	! define the shape to be given to the work array
645	ishape(:) = (/ kidim, kjdim, kkdim, kldim /)
646	! define the starting index of the dimension shape to be given to the work array
647	isrt (:) = (/ kisrt, kjsrt, kksrt, klsrt /)
648	iend (:) = ishape(:) + isrt(:) - 1
649
650	! is it integer or real array?
651	IF( PRESENT(kwrk1d) .OR. PRESENT(kwrk2d) .OR. PRESENT(kwrk3d) .OR. PRESENT(kwrk4d) ) itype = jpinteger
652	IF( PRESENT(pwrk1d) .OR. PRESENT(pwrk2d) .OR. PRESENT(pwrk3d) .OR. PRESENT(pwrk4d) ) itype = jpreal
653
654	! find the branch with the matching shape, staring index and type or get the first "free" branch
655	ii = 1
656	DO WHILE( ( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= isrt ) .OR. tree(ii)%itype /= itype ) &
657	& .AND. SUM( tree(ii)%ishape ) /= 0 )
658	ii = ii + 1
659	IF (ii > jparray) THEN
660	WRITE(numout,*) "E R R O R: NEMO aborted wrk_allocbase"
661	FLUSH(numout)
662	STOP 'Increase the value of jparray'
663	! increase the value of jparray (should not be needed as already very big!)
664	END IF
665	END DO
666
667	IF( SUM( tree(ii)%ishape ) == 0 ) THEN ! create a new branch
668	IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype
669	tree(ii)%itype = itype ! define the type of this branch
670	tree(ii)%ishape(:) = ishape(:) ! define the shape of this branch
671	tree(ii)%istart(:) = isrt(:) ! define the lower bounds of this branch
672	ALLOCATE( tree(ii)%start ) ! allocate its start
673	ALLOCATE( tree(ii)%current) ! allocate the current leaf (the first leaf)
674
675	tree(ii)%start%in_use = .FALSE. ! Never use the start as work array
676	tree(ii)%start%indic = 0
677	tree(ii)%start%prev => NULL() ! nothing before the start
678	tree(ii)%start%next => tree(ii)%current ! first leaf link to the start
679
680	tree(ii)%current%in_use = .FALSE. ! first leaf is not yet used
681	tree(ii)%current%indic = 1 ! first leaf
682	tree(ii)%current%prev => tree(ii)%start ! previous leaf is the start
683	tree(ii)%current%next => NULL() ! next leaf is not yet defined
684	! allocate the array of the first leaf
685	IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) )
686	IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) )
687	IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) )
688	IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
689	IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) )
690	IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) )
691	IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) )
692	IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
693
694	ELSE IF( .NOT. ASSOCIATED(tree(ii)%current%next) ) THEN ! all leafs used -> define a new one
695	ALLOCATE( tree(ii)%current%next ) ! allocate the new leaf
696	tree(ii)%current%next%in_use = .FALSE. ! this leaf is not yet used
697	tree(ii)%current%next%indic = tree(ii)%current%indic + 1 ! number of this leaf
698	IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic
699	tree(ii)%current%next%prev => tree(ii)%current ! previous leaf of the new leaf is the current leaf
700	tree(ii)%current%next%next => NULL() ! next leaf is not yet defined
701
702	tree(ii)%current => tree(ii)%current%next ! the current leaf becomes the new one
703
704	! allocate the array of the new leaf
705	IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) )
706	IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) )
707	IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) )
708	IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
709	IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) )
710	IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) )
711	IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) )
712	IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) )
713
714	ELSE
715	tree(ii)%current => tree(ii)%current%next ! the current leaf becomes the next one
716	ENDIF
717	!
718	! use the array of the current leaf as a work array
719	IF( PRESENT(kwrk1d) ) kwrk1d => tree(ii)%current%iwrk1d
720	IF( PRESENT(kwrk2d) ) kwrk2d => tree(ii)%current%iwrk2d
721	IF( PRESENT(kwrk3d) ) kwrk3d => tree(ii)%current%iwrk3d
722	IF( PRESENT(kwrk4d) ) kwrk4d => tree(ii)%current%iwrk4d
723	IF( PRESENT(pwrk1d) ) pwrk1d => tree(ii)%current%zwrk1d
724	IF( PRESENT(pwrk2d) ) pwrk2d => tree(ii)%current%zwrk2d
725	IF( PRESENT(pwrk3d) ) pwrk3d => tree(ii)%current%zwrk3d
726	IF( PRESENT(pwrk4d) ) pwrk4d => tree(ii)%current%zwrk4d
727	tree(ii)%current%in_use = .TRUE. ! this leaf is now used
728	!
729	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
730	END SUBROUTINE wrk_allocbase
731
732
733	SUBROUTINE wrk_deallocbase( ktype, kidim, kjdim, kkdim, kldim, kisrt, kjsrt, kksrt, klsrt )
734	INTEGER, INTENT(in ) :: ktype
735	INTEGER, INTENT(in ) :: kidim, kjdim, kkdim, kldim
736	INTEGER, INTENT(in ), OPTIONAL :: kisrt, kjsrt, kksrt, klsrt
737	!
738	INTEGER, DIMENSION(jpmaxdim) :: ishape, istart
739	INTEGER :: ii
740	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
741	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
742	REAL(KIND=jprb) :: zhook_handle
743
744	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_DEALLOCBASE'
745
746	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
747
748
749	ishape(:) = (/ kidim, kjdim, kkdim, kldim /)
750	IF( PRESENT(kisrt) ) THEN ; istart(1) = kisrt ; ELSE ; istart(1) = 1 ; ENDIF
751	IF( PRESENT(kjsrt) ) THEN ; istart(2) = kjsrt ; ELSE ; istart(2) = 1 ; ENDIF
752	IF( PRESENT(kksrt) ) THEN ; istart(3) = kksrt ; ELSE ; istart(3) = 1 ; ENDIF
753	IF( PRESENT(klsrt) ) THEN ; istart(4) = klsrt ; ELSE ; istart(4) = 1 ; ENDIF
754
755	! find the branch with the matcing shape and type or get the first "free" branch
756	ii = 1
757	DO WHILE( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= istart ) .OR. tree(ii)%itype /= ktype )
758	ii = ii + 1
759	END DO
760	!
761	tree(ii)%current%in_use = .FALSE. ! current leaf is no more used
762	tree(ii)%current => tree(ii)%current%prev ! move back toward previous leaf
763	!
764	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
765	END SUBROUTINE wrk_deallocbase
766
767
768	SUBROUTINE wrk_stop(cmsg)
769	!!----------------------------------------------------------------------
770	!! * ROUTINE wrk_stop *
771	!! ** Purpose : to act as local alternative to ctl_stop.
772	!! Avoids dependency on in_out_manager module.
773	!!----------------------------------------------------------------------
774	CHARACTER(LEN=*), INTENT(in) :: cmsg
775	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
776	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
777	REAL(KIND=jprb) :: zhook_handle
778
779	CHARACTER(LEN=*), PARAMETER :: RoutineName='WRK_STOP'
780
781	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
782
783	!!----------------------------------------------------------------------
784	!
785	! WRITE(kumout, cform_err2)
786	WRITE(,) TRIM(cmsg)
787	! ARPDBG - would like to CALL mppstop here to force a stop but that
788	! introduces a dependency on lib_mpp. Could CALL mpi_abort() directly
789	! but that's fairly brutal. Better to rely on CALLing routine to
790	! deal with the error passed back from the wrk_X routine?
791	!CALL mppstop
792	!
793	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
794	END SUBROUTINE wrk_stop
795
796	!!=====================================================================
797	END MODULE wrk_nemo

Note: See TracBrowser for help on using the repository browser.

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90

Download in other formats: