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_2.F90 in branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/wrk_nemo_2.F90 @ 3134

Last change on this file since 3134 was 3134, checked in by smasson, 13 years ago

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