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_simple in branches/2011/dev_r2769_LOCEAN_dynamic_mem/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/2011/dev_r2769_LOCEAN_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/wrk_nemo_2.F90_simple @ 2776

Last change on this file since 2776 was 2776, checked in by rblod, 13 years ago

Add a second solution to find automatically an available working array, see ticket #829
File size: 15.9 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         : define in memory the work space arrays
12   !!   wrk_in_use, iwrk_in_use, wrk_in_use_xz : check the availability of a workspace
13   !!   wrk_not_released, iwrk_not_released, wrk_not_released_xz : release the workspace
14   !!   print_in_use_list : print out the table holding which workspace arrays are currently marked as in use
15   !!   get_next_arg      : get the next argument
16   !!   wrk_stop          : act as local alternative to ctl_stop
17   !!----------------------------------------------------------------------
18   USE par_oce        ! ocean parameters
19
20   IMPLICIT NONE
21   PRIVATE
22   
23
24   INTERFACE nemo_allocate
25      MODULE PROCEDURE nemo_allocate_4d, nemo_allocate_3d, nemo_allocate_2d, &
26      &                nemo_allocate_1d, nemo_allocate_2d_i
27   END INTERFACE
28
29   INTERFACE nemo_deallocate
30      MODULE PROCEDURE nemo_deallocate_4d, nemo_deallocate_3d, nemo_deallocate_2d, &
31      &                nemo_deallocate_1d, nemo_deallocate_2d_i
32   END INTERFACE
33   PUBLIC wrk_alloc_2, nemo_allocate, nemo_deallocate
34
35
36   INTEGER, PARAMETER :: num_1d_wrkspaces  = 27   ! No. of 1D workspace arrays ( MAX(jpi*jpj,jpi*jpk,jpj*jpk) )
37   INTEGER, PARAMETER :: num_2d_wrkspaces  = 35   ! No. of 2D workspace arrays (jpi,jpj)
38   INTEGER, PARAMETER :: num_3d_wrkspaces  = 15   ! No. of 3D workspace arrays (jpi,jpj,jpk)
39   INTEGER, PARAMETER :: num_4d_wrkspaces  = 4    ! No. of 4D workspace arrays (jpi,jpj,jpk,jpts)
40
41
42   INTEGER, PARAMETER :: num_xz_wrkspaces  = 4   ! No. of 2D, xz workspace arrays (jpi,jpk)
43
44   INTEGER, PARAMETER :: num_1d_lwrkspaces = 0   ! No. of 1D logical workspace arrays
45   INTEGER, PARAMETER :: num_2d_lwrkspaces = 3   ! No. of 2D logical workspace arrays
46   INTEGER, PARAMETER :: num_3d_lwrkspaces = 1   ! No. of 3D logical workspace arrays
47   INTEGER, PARAMETER :: num_4d_lwrkspaces = 0   ! No. of 4D logical workspace arrays
48
49   INTEGER, PARAMETER :: num_1d_iwrkspaces = 0   ! No. of 1D integer workspace arrays
50   INTEGER, PARAMETER :: num_2d_iwrkspaces = 1   ! No. of 2D integer workspace arrays
51   INTEGER, PARAMETER :: num_3d_iwrkspaces = 0   ! No. of 3D integer workspace arrays
52   INTEGER, PARAMETER :: num_4d_iwrkspaces = 0   ! No. of 4D integer workspace arrays
53   ! Maximum no. of workspaces of any one dimensionality that can be
54   ! requested - MAX(num_1d_wrkspaces, num_2d_wrkspaces, num_3d_wrkspaces, num_4d_wrkspaces)
55   INTEGER :: max_num_wrkspaces = 35
56
57   ! If adding more arrays here, remember to increment the appropriate
58   ! num_Xd_wrkspaces parameter above and to allocate them in wrk_alloc()
59   TYPE work_space_1d
60     LOGICAL ::  in_use
61     REAL(wp), DIMENSION(:), POINTER :: wrk   
62   END TYPE
63   TYPE(work_space_1d), DIMENSION(num_1d_wrkspaces) :: s_wrk_1d
64   INTEGER :: n_wrk_1d
65
66   TYPE work_space_2d
67     LOGICAL ::  in_use
68     REAL(wp), DIMENSION(:,:), POINTER:: wrk   
69   END TYPE
70   TYPE(work_space_2d), DIMENSION(num_2d_wrkspaces) :: s_wrk_2d
71   INTEGER :: n_wrk_2d
72
73   TYPE work_space_xz
74     LOGICAL ::  in_use
75     REAL(wp), DIMENSION(:,:), POINTER :: wrk   
76   END TYPE
77   TYPE(work_space_xz), DIMENSION(num_xz_wrkspaces) :: s_wrk_xz
78   INTEGER :: n_wrk_xz
79
80   TYPE work_space_3d
81     LOGICAL ::  in_use
82     REAL(wp), DIMENSION(:,:,:), POINTER :: wrk   
83   END TYPE
84   TYPE(work_space_3d), DIMENSION(num_3d_wrkspaces) :: s_wrk_3d
85   INTEGER :: n_wrk_3d
86
87   TYPE work_space_4d
88     LOGICAL ::  in_use
89     REAL(wp), DIMENSION(:,:,:,:), POINTER :: wrk   
90   END TYPE
91   TYPE(work_space_4d), DIMENSION(num_4d_wrkspaces) :: s_wrk_4d
92   INTEGER :: n_wrk_4d
93
94   TYPE work_space_2d_i
95     LOGICAL ::  in_use
96     INTEGER, DIMENSION(:,:), POINTER :: wrk   
97   END TYPE
98   TYPE(work_space_2d_i), DIMENSION(num_2d_iwrkspaces) :: s_wrk_2d_i
99   INTEGER :: n_wrk_2d_i
100   
101
102   ! Labels for specifying workspace type in call to print_in_use_list()
103   INTEGER, PARAMETER ::   INTEGER_TYPE = 0
104   INTEGER, PARAMETER ::   LOGICAL_TYPE = 1
105   INTEGER, PARAMETER ::   REAL_TYPE    = 2
106
107   INTEGER :: kumout  ! Local copy of numout unit number for error/warning messages
108   LOGICAL :: llwp    ! Local copy of lwp - whether we are master PE or not
109
110   CHARACTER(LEN=*), PARAMETER ::   cform_err2 = "(/,' ===>>> : E R R O R',     /,'         ===========',/)"       !:
111   CHARACTER(LEN=*), PARAMETER ::   cform_war2 = "(/,' ===>>> : W A R N I N G', /,'         ===============',/)"   !:
112
113   !!----------------------------------------------------------------------
114   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
115   !! $Id:$
116   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
117   !!----------------------------------------------------------------------
118CONTAINS
119
120  FUNCTION wrk_alloc_2(iunit, lwp_arg)
121      !!----------------------------------------------------------------------
122      !!                   ***  FUNCTION wrk_alloc  ***
123      !!
124      !! ** Purpose :   Define in memory once for all the NEMO 2D, 3D and 4d
125      !!                work space arrays
126      !!----------------------------------------------------------------------
127      INTEGER, INTENT(in) ::   iunit         ! Unit no. to use for error/warning messages in this module
128      LOGICAL, INTENT(in) ::   lwp_arg       ! Value of lwp
129      !
130      INTEGER :: ji
131      INTEGER ::   wrk_alloc_2   ! Return value
132      INTEGER ::   extent_1d   ! Extent to allocate for 1D arrays
133      INTEGER, DIMENSION(:), ALLOCATABLE ::   ierror   ! local integer
134      !!----------------------------------------------------------------------
135      !
136      ! Save the unit number to use for err/warning messages
137      kumout = iunit
138      ! Save whether we are master PE or not (for output messages)
139      llwp = lwp_arg
140      !
141      ALLOCATE(ierror(num_1d_wrkspaces+num_2d_wrkspaces+num_3d_wrkspaces &
142                   & + num_4d_wrkspaces+num_xz_wrkspaces+num_2d_iwrkspaces) )
143      !
144      ! Extent to use for 1D work arrays - find the maximum product of
145      ! jpi*jpj, jpi*jpk and jpj*jpk and use that
146      IF    ( jpi < jpj .AND. jpi < jpk ) THEN   ;   extent_1d = jpj*jpk
147      ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN   ;   extent_1d = jpi*jpk
148      ELSE                                       ;   extent_1d = jpi*jpj
149      ENDIF
150      !
151      ierror(:) = 0
152      !
153      n_wrk_1d   = 1
154      n_wrk_2d   = 1
155      n_wrk_3d   = 1
156      n_wrk_4d   = 1
157      n_wrk_xz   = 1
158      n_wrk_2d_i = 1
159     
160      DO ji = 1, num_1d_wrkspaces
161       s_wrk_1d(ji)%in_use = .FALSE.
162       ALLOCATE( s_wrk_1d(ji)%wrk(extent_1d), STAT=ierror(ji) )
163      END DO
164      DO ji = 1, num_2d_wrkspaces
165       s_wrk_2d(ji)%in_use = .FALSE.
166       ALLOCATE( s_wrk_2d(ji)%wrk(jpi,jpj), STAT=ierror(ji+num_1d_wrkspaces) )
167      END DO
168      DO ji = 1, num_3d_wrkspaces
169       s_wrk_3d(ji)%in_use = .FALSE.
170       ALLOCATE( s_wrk_3d(ji)%wrk(jpi,jpj,jpk), STAT=ierror(ji+num_2d_wrkspaces) )
171      END DO
172      DO ji = 1, num_4d_wrkspaces
173       s_wrk_4d(ji)%in_use = .FALSE.
174       ALLOCATE( s_wrk_4d(ji)%wrk(jpi,jpj,jpk,jpts), STAT=ierror(ji+num_3d_wrkspaces) )
175      END DO
176      DO ji = 1, num_xz_wrkspaces
177       s_wrk_xz(ji)%in_use = .FALSE.
178       ALLOCATE( s_wrk_xz(ji)%wrk(jpi,jpk), STAT=ierror(ji+num_4d_wrkspaces) )
179      END DO
180      DO ji = 1, num_2d_iwrkspaces
181       s_wrk_2d_i(ji)%in_use = .FALSE.
182       ALLOCATE( s_wrk_2d_i(ji)%wrk(jpi,jpj), STAT=ierror(ji+num_xz_wrkspaces) )
183      END DO
184      !
185      wrk_alloc_2 = MAXVAL( ierror )
186      !
187      ! Calling routine, nemo_alloc(), checks for errors and takes
188      ! appropriate action - we just print a warning message
189      IF( wrk_alloc_2 /= 0 ) THEN
190         WRITE(kumout,cform_war2)
191         WRITE(kumout,*) 'wrk_alloc: allocation of workspace arrays failed'
192      ENDIF
193      !
194   END FUNCTION wrk_alloc_2
195
196
197   SUBROUTINE nemo_allocate_4d( ptab4d, pidim, pjdim, pkdim, pldim )
198      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: ptab4d
199      INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim, pkdim, pldim   
200      !
201      INTEGER :: ji, jx, jy, jz, jt
202     
203      IF( PRESENT(pidim) ) THEN
204         jx = pidim
205         jy = pjdim
206         jz = pkdim
207         jt = pldim
208      ELSE
209         jx = jpi
210         jy = jpj   
211         jz = jpk
212         jt = jpts   
213      ENDIF
214     
215      ptab4d => s_wrk_4d(n_wrk_4d)%wrk(1:jx,1:jy,1:jz,1:jt)
216      s_wrk_4d(n_wrk_4d)%in_use = .TRUE.         
217      n_wrk_4d = n_wrk_4d + 1
218     
219   END SUBROUTINE nemo_allocate_4d
220   
221   SUBROUTINE nemo_allocate_3d( ptab3d, pidim, pjdim, pkdim )
222      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: ptab3d 
223      INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim, pkdim   
224      !
225      INTEGER :: ji, jx, jy, jz
226
227      IF( PRESENT(pidim) ) THEN
228         jx = pidim
229         jy = pjdim
230         jz = pkdim
231      ELSE
232         jx = jpi
233         jy = jpj   
234         jz = jpk   
235      ENDIF
236     
237      ptab3d => s_wrk_3d(n_wrk_3d)%wrk(1:jx,1:jy,1:jz)
238      s_wrk_3d(n_wrk_3d)%in_use = .TRUE.         
239      n_wrk_3d = n_wrk_3d + 1
240     
241   END SUBROUTINE nemo_allocate_3d
242
243   SUBROUTINE nemo_allocate_2d( ptab2d, pidim, pjdim )
244      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d
245      INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim   
246      !
247      INTEGER :: jx, jy
248     
249      IF( PRESENT(pidim) ) THEN
250         jx = pidim
251         jy = pjdim
252         ptab2d => s_wrk_xz(n_wrk_xz)%wrk(1:jx,1:jy)
253         s_wrk_xz(n_wrk_xz)%in_use = .TRUE.         
254         n_wrk_xz = n_wrk_xz + 1
255      ELSE
256         jx = jpi
257         jy = jpj   
258         ptab2d => s_wrk_2d(n_wrk_2d)%wrk(:,:)
259         s_wrk_2d(n_wrk_2d)%in_use = .TRUE.         
260         n_wrk_2d = n_wrk_2d + 1
261      ENDIF
262               
263   END SUBROUTINE nemo_allocate_2d
264
265   SUBROUTINE nemo_allocate_1d( ptab1d )
266      REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: ptab1d
267      !
268     
269      ptab1d => s_wrk_1d(n_wrk_1d)%wrk(:)
270      s_wrk_1d(n_wrk_1d)%in_use = .TRUE.         
271      n_wrk_1d = n_wrk_1d + 1
272   
273   END SUBROUTINE nemo_allocate_1d
274
275   SUBROUTINE nemo_allocate_2d_i( ptab2d )
276      INTEGER, POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d   
277      !
278      INTEGER :: ji
279      LOGICAL :: l_in_use
280     
281      ptab2d => s_wrk_2d_i(n_wrk_2d_i)%wrk(:,:)
282      s_wrk_2d_i(n_wrk_2d)%in_use = .TRUE.         
283      n_wrk_2d_i = n_wrk_2d_i + 1
284           
285   END SUBROUTINE nemo_allocate_2d_i
286
287   SUBROUTINE nemo_deallocate_4d( ptab4d )
288      REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: ptab4d
289     
290      NULLIFY(ptab4d)
291      s_wrk_4d(n_wrk_4d)%in_use = .FALSE.       
292      n_wrk_4d = n_wrk_4d - 1
293     
294   END SUBROUTINE nemo_deallocate_4d
295   
296   SUBROUTINE nemo_deallocate_3d( ptab3d)
297      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: ptab3d 
298      !
299     
300      NULLIFY(ptab3d)
301      s_wrk_3d(n_wrk_3d)%in_use = .FALSE.         
302      n_wrk_3d = n_wrk_3d - 1
303     
304   END SUBROUTINE nemo_deallocate_3d
305
306   SUBROUTINE nemo_deallocate_2d( ptab2d, pidim, pjdim )
307      REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d
308      INTEGER, OPTIONAL, INTENT(in) :: pidim, pjdim   
309      !
310      INTEGER :: jx, jy
311     
312      IF( PRESENT(pidim) ) THEN
313         jx = pidim
314         jy = pjdim
315         NULLIFY(ptab2d)
316         s_wrk_xz(n_wrk_xz)%in_use = .FALSE.         
317         n_wrk_xz = n_wrk_xz - 1
318      ELSE
319         jx = jpi
320         jy = jpj   
321         NULLIFY(ptab2d)
322         s_wrk_2d(n_wrk_2d)%in_use = .FALSE.         
323         n_wrk_2d = n_wrk_2d - 1
324      ENDIF
325               
326   END SUBROUTINE nemo_deallocate_2d
327
328   SUBROUTINE nemo_deallocate_1d( ptab1d )
329      REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: ptab1d
330      !
331     
332      NULLIFY(ptab1d)
333      s_wrk_1d(n_wrk_1d)%in_use = .FALSE.         
334      n_wrk_1d = n_wrk_1d - 1
335   
336   END SUBROUTINE nemo_deallocate_1d
337
338   SUBROUTINE nemo_deallocate_2d_i( ptab2d )
339      INTEGER, POINTER, DIMENSION(:,:), INTENT(inout) :: ptab2d   
340      !
341     
342      NULLIFY(ptab2d)
343      s_wrk_2d_i(n_wrk_2d)%in_use = .FALSE.         
344      n_wrk_2d_i = n_wrk_2d_i - 1
345           
346   END SUBROUTINE nemo_deallocate_2d_i
347
348
349   SUBROUTINE print_in_use_list( kdim, itype, in_use_list )
350      !!----------------------------------------------------------------------
351      !!                 *** ROUTINE print_in_use_list ***
352      !!
353      !! ** Purpose:   to print out the table holding which workspace arrays
354      !!             are currently marked as in use.
355      !!----------------------------------------------------------------------
356      INTEGER,               INTENT(in) :: kdim
357      INTEGER,               INTENT(in) :: itype
358      LOGICAL, DIMENSION(:), INTENT(in) :: in_use_list
359      !
360      INTEGER          ::   ji, icount
361      CHARACTER(LEN=7) ::   type_string
362      !!----------------------------------------------------------------------
363      !
364      IF(.NOT. llwp)   RETURN
365      !
366      SELECT CASE ( kdim )
367      !
368      CASE (1)
369         SELECT CASE (itype)
370         CASE (INTEGER_TYPE)   ;   icount = num_1d_iwrkspaces
371         CASE (LOGICAL_TYPE)   ;   icount = num_1d_lwrkspaces
372         CASE (REAL_TYPE   )   ;   icount = num_1d_wrkspaces
373         END SELECT
374         !
375      CASE (2)
376         SELECT CASE (itype)
377         CASE (INTEGER_TYPE)   ;   icount = num_2d_iwrkspaces
378         CASE (LOGICAL_TYPE)   ;   icount = num_2d_lwrkspaces
379         CASE (REAL_TYPE   )   ;   icount = num_2d_wrkspaces
380         END SELECT
381         !
382      CASE (3)
383         SELECT CASE (itype)
384         CASE (INTEGER_TYPE)   ;   icount = num_3d_iwrkspaces
385         CASE (LOGICAL_TYPE)   ;   icount = num_3d_lwrkspaces
386         CASE (REAL_TYPE   )   ;   icount = num_3d_wrkspaces
387         END SELECT
388         !
389      CASE (4)
390         SELECT CASE (itype)
391         CASE (INTEGER_TYPE)   ;   icount = num_4d_iwrkspaces
392         CASE (LOGICAL_TYPE)   ;   icount = num_4d_lwrkspaces
393         CASE (REAL_TYPE   )   ;   icount = num_4d_wrkspaces
394         END SELECT
395         !
396      CASE DEFAULT   ;   RETURN
397      !
398      END SELECT
399      !
400      ! Set character string with type of workspace
401      SELECT CASE (itype)
402      CASE (INTEGER_TYPE)   ;   type_string = "INTEGER"
403      CASE (LOGICAL_TYPE)   ;   type_string = "LOGICAL"
404      CASE (REAL_TYPE   )   ;   type_string = "REAL"
405      END SELECT
406      !
407      WRITE(kumout,*)
408      WRITE(kumout,"('------------------------------------------')")
409      WRITE(kumout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string)
410      WRITE(kumout,"('Workspace   In use')")
411      DO ji = 1, icount, 1
412         WRITE(kumout,"(4x,I2,8x,L1)") ji, in_use_list(ji)
413      END DO
414      WRITE(kumout,"('------------------------------------------')")
415      WRITE(kumout,*)
416      !
417   END SUBROUTINE print_in_use_list
418
419
420   SUBROUTINE wrk_stop(cmsg)
421      !!----------------------------------------------------------------------
422      !!               ***  ROUTINE wrk_stop  ***
423      !! ** Purpose :   to act as local alternative to ctl_stop.
424      !!                Avoids dependency on in_out_manager module.
425      !!----------------------------------------------------------------------
426      CHARACTER(LEN=*), INTENT(in) :: cmsg
427      !!----------------------------------------------------------------------
428      !
429      WRITE(kumout, cform_err2)
430      WRITE(kumout,*) TRIM(cmsg)
431      ! ARPDBG - would like to call mppstop here to force a stop but that
432      ! introduces a dependency on lib_mpp. Could call mpi_abort() directly
433      ! but that's fairly brutal. Better to rely on calling routine to
434      ! deal with the error passed back from the wrk_X routine?
435      !CALL mppstop
436      !
437   END SUBROUTINE wrk_stop
438
439   !!=====================================================================
440END MODULE wrk_nemo_2
Note: See TracBrowser for help on using the repository browser.