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 @ 2704

Last change on this file since 2704 was 2704, checked in by cetlod, 11 years ago

Used correct working arrays in print control routines used for debugging : prtctl.F90 & prtctl_trc.F90

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