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/2012/dev_NOC_MERCATOR_2012/NEMOGCM/NEMO/TOP_SRC – NEMO

source: branches/2012/dev_NOC_MERCATOR_2012/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 3649

Last change on this file since 3649 was 3294, checked in by rblod, 12 years ago

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