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

Last change on this file since 1715 was 1581, checked in by smasson, 15 years ago

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