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 trunk/NEMO/TOP_SRC – NEMO

source: trunk/NEMO/TOP_SRC/prtctl_trc.F90 @ 719

Last change on this file since 719 was 719, checked in by ctlod, 17 years ago

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