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.
prtctl_trc.F90 in branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/TOP_SRC – NEMO

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 2643

Last change on this file since 2643 was 2643, checked in by cetlod, 13 years ago

Changed TOP/PISCES to use dynamic memory & improve the others TOP modules
  • Property svn:keywords set to Id
File size: 20.4 KB
Line 
1MODULE prtctl_trc
2   !!======================================================================
3   !!                         ***  MODULE prtctl_trc  ***
4   !! TOP :   print all SUM trends for each processor domain
5   !!======================================================================
6   !! History :    -   !  2005-07  (C. Talandier) original code for OPA
7   !!             1.0  !  2005-10  (C. Ethe     ) adapted to passive tracer
8   !!----------------------------------------------------------------------
9#if defined key_top
10   !!----------------------------------------------------------------------
11   !!   'key_top'                                                TOP models
12   !!----------------------------------------------------------------------
13   !!   prt_ctl_trc      :   control print in mpp for passive tracers
14   !!   prt_ctl_trc_info :   ???
15   !!   prt_ctl_trc_init :   ???
16   !!----------------------------------------------------------------------
17   USE par_trc          ! TOP parameters
18   USE oce_trc          ! ocean space and time domain variables
19
20   IMPLICIT NONE
21   PRIVATE
22
23   INTEGER , DIMENSION(:), ALLOCATABLE ::   numid_trc          !: logical unit
24   INTEGER , DIMENSION(:), ALLOCATABLE ::   nlditl , nldjtl    !: first, last indoor index for each i-domain
25   INTEGER , DIMENSION(:), ALLOCATABLE ::   nleitl , nlejtl    !: first, last indoor index for each j-domain
26   INTEGER , DIMENSION(:), ALLOCATABLE ::   nimpptl, njmpptl   !: i-, j-indexes for each processor
27   INTEGER , DIMENSION(:), ALLOCATABLE ::   nlcitl , nlcjtl    !: dimensions of every subdomain
28   INTEGER , DIMENSION(:), ALLOCATABLE ::   ibonitl, ibonjtl
29
30   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   tra_ctl         !: previous trend values
31
32   PUBLIC prt_ctl_trc         ! called by all subroutines
33   PUBLIC prt_ctl_trc_info    !
34   PUBLIC prt_ctl_trc_init    ! called by opa.F90
35
36CONTAINS
37
38   SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
39      !!----------------------------------------------------------------------
40      !!                     ***  ROUTINE prt_ctl  ***
41      !!
42      !! ** Purpose : - print sum control 3D arrays over the same area
43      !!                in mono and mpp case. This way can be usefull when
44      !!                debugging a new parametrization in mono or mpp.
45      !!
46      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
47      !!                .true. in the ocean namelist:
48      !!              - to debug a MPI run .vs. a mono-processor one;
49      !!                the control print will be done over each sub-domain.
50      !!                The nictl[se] and njctl[se] parameters in the namelist must
51      !!                be set to zero and [ij]splt to the corresponding splitted
52      !!                domain in MPI along respectively i-, j- directions.
53      !!              - to debug a mono-processor run over the whole domain/a specific area;
54      !!                in the first case the nictl[se] and njctl[se] parameters must be set
55      !!                to zero else to the indices of the area to be controled. In both cases
56      !!                isplt and jsplt must be set to 1.
57      !!              - All arguments of the above calling sequence are optional so their
58      !!                name must be explicitly typed if used. For instance if the mask
59      !!                array tmask(:,:,:) must be passed through the prt_ctl subroutine,
60      !!                it must looks like: CALL prt_ctl( mask=tmask ).
61      !!----------------------------------------------------------------------
62      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
63      USE wrk_nemo, ONLY: zmask => wrk_3d_1, ztab3d => wrk_3d_2
64      !!
65      REAL(wp)         , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d     ! 4D array
66      REAL(wp)         , DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask      ! 3D mask to apply to the tab4d array
67      CHARACTER (len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array
68      CHARACTER (len=*)                    , INTENT(in), OPTIONAL ::   clinfo2   ! ???
69      INTEGER                              , INTENT(in), OPTIONAL ::   ovlap     ! overlap value
70      INTEGER                              , INTENT(in), OPTIONAL ::   kdim      ! k- direction for 4D arrays
71      !!
72      INTEGER  ::   overlap, jn, js, sind, eind, kdir, j_id
73      REAL(wp) ::   zsum, zvctl
74      CHARACTER (len=20), DIMENSION(jptra) ::   cl
75      CHARACTER (len=10) ::   cl2
76      !!----------------------------------------------------------------------
77
78      IF( wrk_in_use(3, 1,2) ) THEN
79         CALL ctl_stop('prt_ctl_trc : requested workspace arrays unavailable.')
80         RETURN
81      END IF
82
83      !                                      ! Arrays, scalars initialization
84      overlap       = 0
85      kdir          = jpkm1
86      zsum          = 0.e0
87      zvctl         = 0.e0
88      cl(:)         = ''
89      cl2           = ''
90      ztab3d(:,:,:) = 0.e0
91      zmask (:,:,:) = 1.e0
92
93      !                                      ! Control of optional arguments
94      IF( PRESENT(ovlap)   )   overlap       = ovlap
95      IF( PRESENT(kdim)    )   kdir          = kdim
96      IF( PRESENT(clinfo ) )   cl(:)         = clinfo(:)
97      IF( PRESENT(clinfo2) )   cl2           = clinfo2
98      IF( PRESENT(mask)    )   zmask (:,:,:) = mask(:,:,:)
99
100      IF( lk_mpp )   THEN      ! processor number
101         sind = narea
102         eind = narea
103      ELSE                     ! processors total number
104         sind = 1
105         eind = ijsplt
106      ENDIF
107
108      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
109      DO js = sind, eind
110         !
111         ! Set logical unit
112         j_id = numid_trc( js - narea + 1 )
113         ! Set indices for the SUM control
114         IF( .NOT. lsp_area ) THEN
115            IF (lk_mpp )   THEN
116               nictls = MAX( 1, nlditl(js) - overlap )
117               nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js)) 
118               njctls = MAX( 1, nldjtl(js) - overlap )
119               njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
120               ! Do not take into account the bound of the domain
121               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
122               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nleitl(js) - 1 )
123               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
124               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, nlejtl(js) - 1 )
125            ELSE
126               nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
127               nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) ) 
128               njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
129               njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) ) 
130               ! Do not take into account the bound of the domain
131               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
132               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
133               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
134               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
135            ENDIF
136         ENDIF
137         !
138         IF( PRESENT(clinfo2) ) THEN
139            DO jn = 1, jptra
140               zvctl  = tra_ctl(jn,js)
141               ztab3d(:,:,:) = tab4d(:,:,:,jn)
142               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
143                  &                * zmask(nictls:nictle,njctls:njctle,1:kdir) )
144               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
145               tra_ctl(jn,js) = zsum
146            END DO
147         ELSE
148            DO jn = 1, jptra
149               ztab3d(:,:,:) = tab4d(:,:,:,jn)
150               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
151                  &               *  zmask(nictls:nictle,njctls:njctle,1:kdir) )
152               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
153            END DO
154         ENDIF
155         !
156      END DO
157      !
158      IF( wrk_not_released(3, 1,2) ) CALL ctl_stop('prt_ctl_trc : failed to release workspace arrays.')
159      !
160   END SUBROUTINE prt_ctl_trc
161
162
163   SUBROUTINE prt_ctl_trc_info( clinfo )
164      !!----------------------------------------------------------------------
165      !!                     ***  ROUTINE prt_ctl_trc_info  ***
166      !!
167      !! ** Purpose : - print information without any computation
168      !!----------------------------------------------------------------------
169      CHARACTER (len=*), INTENT(in) ::   clinfo      ! information to print
170      !!
171      INTEGER ::   js, sind, eind, j_id
172      !!----------------------------------------------------------------------
173
174      IF( lk_mpp ) THEN      ! processor number
175         sind = narea
176         eind = narea
177      ELSE                   ! total number of processors
178         sind = 1
179         eind = ijsplt
180      ENDIF
181
182      ! Loop over each sub-domain, i.e. number of processors ijsplt
183      DO js = sind, eind
184         j_id = numid_trc(js - narea + 1)
185         WRITE(j_id,*) clinfo
186      END DO
187      !
188   END SUBROUTINE prt_ctl_trc_info
189
190
191   SUBROUTINE prt_ctl_trc_init
192      !!----------------------------------------------------------------------
193      !!                     ***  ROUTINE prt_ctl_trc_init  ***
194      !!
195      !! ** Purpose :   open ASCII files & compute indices
196      !!----------------------------------------------------------------------
197      INTEGER            ::   js, sind, eind, j_id
198      CHARACTER (len=31) :: clfile_out
199      CHARACTER (len=27) :: clb_name
200      CHARACTER (len=19) :: cl_run
201      !!----------------------------------------------------------------------
202
203      !                             ! Allocate arrays
204      ALLOCATE( nlditl (ijsplt) )
205      ALLOCATE( nldjtl (ijsplt) )
206      ALLOCATE( nleitl (ijsplt) )
207      ALLOCATE( nlejtl (ijsplt) )
208      ALLOCATE( nimpptl(ijsplt) )
209      ALLOCATE( njmpptl(ijsplt) )
210      ALLOCATE( nlcitl (ijsplt) )
211      ALLOCATE( nlcjtl (ijsplt) )
212      ALLOCATE( tra_ctl(jptra,ijsplt) )
213      ALLOCATE( ibonitl(ijsplt) )
214      ALLOCATE( ibonjtl(ijsplt) )
215
216      tra_ctl(:,:) = 0.e0           ! Initialization to zero
217
218      IF( lk_mpp ) THEN
219         sind = narea
220         eind = narea
221         clb_name = "('mpp.top.output_',I3.3)"
222         cl_run = 'MULTI processor run'
223         ! use indices for each area computed by mpp_init subroutine
224         nlditl(:) = nldit(:) 
225         nleitl(:) = nleit(:) 
226         nldjtl(:) = nldjt(:) 
227         nlejtl(:) = nlejt(:) 
228         !
229         nimpptl(:) = nimppt(:)
230         njmpptl(:) = njmppt(:)
231         !
232         nlcitl(:) = nlcit(:)
233         nlcjtl(:) = nlcjt(:)
234         !
235         ibonitl(:) = ibonit(:)
236         ibonjtl(:) = ibonjt(:)
237      ELSE
238         sind = 1
239         eind = ijsplt
240         clb_name = "('mono.top.output_',I3.3)"
241         cl_run   = 'MONO processor run '
242         ! compute indices for each area as done in mpp_init subroutine
243         CALL sub_dom
244      ENDIF
245
246      ALLOCATE( numid_trc(eind-sind+1) )
247
248      DO js = sind, eind
249         WRITE(clfile_out,FMT=clb_name) js-1
250         CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
251         j_id = numid_trc(js -narea + 1)
252         WRITE(j_id,*)
253         WRITE(j_id,*) '                 L O D Y C - I P S L'
254         WRITE(j_id,*) '                       N E M 0 '
255         WRITE(j_id,*) '            Ocean General Circulation Model'
256         WRITE(j_id,*) '               version TOP 1.0  (2005) '
257         WRITE(j_id,*)
258         WRITE(j_id,*) '                   PROC number: ', js
259         WRITE(j_id,*)
260         WRITE(j_id,FMT="(19x,a20)") cl_run
261
262         ! Print the SUM control indices
263         IF( .NOT. lsp_area )   THEN
264            IF ( lk_mpp )   THEN
265               nictls = nlditl(js) 
266               nictle = nleitl(js)
267               njctls = nldjtl(js)
268               njctle = nlejtl(js)
269            ELSE
270               nictls = nimpptl(js) + nlditl(js) - 1
271               nictle = nimpptl(js) + nleitl(js) - 1
272               njctls = njmpptl(js) + nldjtl(js) - 1
273               njctle = njmpptl(js) + nlejtl(js) - 1
274            ENDIF
275         ENDIF
276         WRITE(j_id,*) 
277         WRITE(j_id,*) 'prt_tra_ctl :  Sum control indices'
278         WRITE(j_id,*) '~~~~~~~'
279         WRITE(j_id,*)
280         WRITE(j_id,9000)'                                nlej   = ', nlejtl(js), '              '
281         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
282         WRITE(j_id,9001)'                  |                                       |'
283         WRITE(j_id,9001)'                  |                                       |'
284         WRITE(j_id,9001)'                  |                                       |'
285         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
286         WRITE(j_id,9002)'           nldi   = ', nlditl(js),  '                           nlei   = ', nleitl(js)
287         WRITE(j_id,9001)'                  |                                       |'
288         WRITE(j_id,9001)'                  |                                       |'
289         WRITE(j_id,9001)'                  |                                       |'
290         WRITE(j_id,9004)'  njmpp  = ',njmpptl(js),'   ------------- njctls = ', njctls, ' -------------'
291         WRITE(j_id,9003)'           nimpp  = ', nimpptl(js), '        nldj   = ', nldjtl(js), '              '
292         WRITE(j_id,*)
293         WRITE(j_id,*)
294
2959000     FORMAT(a41,i4.4,a14)
2969001     FORMAT(a59)
2979002     FORMAT(a20,i4.4,a36,i3.3)
2989003     FORMAT(a20,i4.4,a17,i4.4)
2999004     FORMAT(a11,i4.4,a26,i4.4,a14)
300      END DO
301      !
302   END SUBROUTINE prt_ctl_trc_init
303
304
305   SUBROUTINE sub_dom
306      !!----------------------------------------------------------------------
307      !!                  ***  ROUTINE sub_dom  ***
308      !!                   
309      !! ** Purpose :   Lay out the global domain over processors.
310      !!                CAUTION:
311      !!                This part has been extracted from the mpp_init
312      !!                subroutine and names of variables/arrays have been
313      !!                slightly changed to avoid confusion but the computation
314      !!                is exactly the same. Any modification about indices of
315      !!                each sub-domain in the mppini.F90 module should be reported
316      !!                here.
317      !!
318      !! ** Method  :   Global domain is distributed in smaller local domains.
319      !!                Periodic condition is a function of the local domain position
320      !!                (global boundary or neighbouring domain) and of the global
321      !!                periodic
322      !!                Type :         jperio global periodic condition
323      !!                               nperio local  periodic condition
324      !!
325      !! ** Action  : - set domain parameters
326      !!                    nimpp     : longitudinal index
327      !!                    njmpp     : latitudinal  index
328      !!                    nperio    : lateral condition type
329      !!                    narea     : number for local area
330      !!                    nlcil      : first dimension
331      !!                    nlcjl      : second dimension
332      !!                    nbondil    : mark for "east-west local boundary"
333      !!                    nbondjl    : mark for "north-south local boundary"
334      !!----------------------------------------------------------------------
335      INTEGER ::   ji, jj, js               ! dummy loop indices
336      INTEGER ::   ii, ij                   ! temporary integers
337      INTEGER ::   irestil, irestjl         !    "          "
338      INTEGER ::   ijpi  , ijpj, nlcil      ! temporary logical unit
339      INTEGER ::   nlcjl , nbondil, nbondjl
340      INTEGER ::   nrecil, nrecjl, nldil, nleil, nldjl, nlejl
341      REAL(wp) ::   zidom, zjdom            ! temporary scalars
342      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! temporary workspace
343      !!----------------------------------------------------------------------
344
345      ! Dimension arrays for subdomains
346      ! -------------------------------
347      !  Computation of local domain sizes ilcitl() ilcjtl()
348      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
349      !  The subdomains are squares leeser than or equal to the global
350      !  dimensions divided by the number of processors minus the overlap
351      !  array (cf. par_oce.F90).
352
353      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
354      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
355
356      ALLOCATE( ilcitl (isplt,jsplt) )
357      ALLOCATE( ilcjtl (isplt,jsplt) )
358
359      nrecil  = 2 * jpreci
360      nrecjl  = 2 * jprecj
361      irestil = MOD( jpiglo - nrecil , isplt )
362      irestjl = MOD( jpjglo - nrecjl , jsplt )
363
364      IF(  irestil == 0 )   irestil = isplt
365      DO jj = 1, jsplt
366         DO ji = 1, irestil
367            ilcitl(ji,jj) = ijpi
368         END DO
369         DO ji = irestil+1, isplt
370            ilcitl(ji,jj) = ijpi -1
371         END DO
372      END DO
373     
374      IF( irestjl == 0 )   irestjl = jsplt
375      DO ji = 1, isplt
376         DO jj = 1, irestjl
377            ilcjtl(ji,jj) = ijpj
378         END DO
379         DO jj = irestjl+1, jsplt
380            ilcjtl(ji,jj) = ijpj -1
381         END DO
382      END DO
383     
384      zidom = nrecil
385      DO ji = 1, isplt
386         zidom = zidom + ilcitl(ji,1) - nrecil
387      END DO
388     
389      zjdom = nrecjl
390      DO jj = 1, jsplt
391         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
392      END DO
393
394      ! Index arrays for subdomains
395      ! ---------------------------
396
397      ALLOCATE( iimpptl(isplt,jsplt) )
398      ALLOCATE( ijmpptl(isplt,jsplt) )
399     
400      iimpptl(:,:) = 1
401      ijmpptl(:,:) = 1
402     
403      IF( isplt > 1 ) THEN
404         DO jj = 1, jsplt
405            DO ji = 2, isplt
406               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
407            END DO
408         END DO
409      ENDIF
410
411      IF( jsplt > 1 ) THEN
412         DO jj = 2, jsplt
413            DO ji = 1, isplt
414               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
415            END DO
416         END DO
417      ENDIF
418     
419      ! Subdomain description
420      ! ---------------------
421
422      DO js = 1, ijsplt
423         ii = 1 + MOD( js-1, isplt )
424         ij = 1 + (js-1) / isplt
425         nimpptl(js) = iimpptl(ii,ij)
426         njmpptl(js) = ijmpptl(ii,ij)
427         nlcitl (js) = ilcitl (ii,ij)     
428         nlcil       = nlcitl (js)     
429         nlcjtl (js) = ilcjtl (ii,ij)     
430         nlcjl       = nlcjtl (js)
431         nbondjl = -1                                    ! general case
432         IF( js   >  isplt          )   nbondjl = 0      ! first row of processor
433         IF( js   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
434         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
435         ibonjtl(js) = nbondjl
436         
437         nbondil = 0                                     !
438         IF( MOD( js, isplt ) == 1 )   nbondil = -1      !
439         IF( MOD( js, isplt ) == 0 )   nbondil =  1      !
440         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
441         ibonitl(js) = nbondil
442         
443         nldil =  1   + jpreci
444         nleil = nlcil - jpreci
445         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
446         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
447         nldjl =  1   + jprecj
448         nlejl = nlcjl - jprecj
449         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
450         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
451         nlditl(js) = nldil
452         nleitl(js) = nleil
453         nldjtl(js) = nldjl
454         nlejtl(js) = nlejl
455      END DO
456
457      DEALLOCATE( iimpptl )
458      DEALLOCATE( ijmpptl )
459      DEALLOCATE( ilcitl )
460      DEALLOCATE( ilcjtl )
461      !
462   END SUBROUTINE sub_dom
463 
464#else
465   !!----------------------------------------------------------------------
466   !!   Dummy module :                                    NO passive tracer
467   !!----------------------------------------------------------------------
468#endif
469 
470   !!----------------------------------------------------------------------
471   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
472   !! $Id$
473   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
474   !!======================================================================   
475END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.