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

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 2281

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

set proper svn properties to all files...
  • 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   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
38CONTAINS
39
40   SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
41      !!----------------------------------------------------------------------
42      !!                     ***  ROUTINE prt_ctl  ***
43      !!
44      !! ** Purpose : - print sum control 3D arrays over the same area
45      !!                in mono and mpp case. This way can be usefull when
46      !!                debugging a new parametrization in mono or mpp.
47      !!
48      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
49      !!                .true. in the ocean namelist:
50      !!              - to debug a MPI run .vs. a mono-processor one;
51      !!                the control print will be done over each sub-domain.
52      !!                The nictl[se] and njctl[se] parameters in the namelist must
53      !!                be set to zero and [ij]splt to the corresponding splitted
54      !!                domain in MPI along respectively i-, j- directions.
55      !!              - to debug a mono-processor run over the whole domain/a specific area;
56      !!                in the first case the nictl[se] and njctl[se] parameters must be set
57      !!                to zero else to the indices of the area to be controled. In both cases
58      !!                isplt and jsplt must be set to 1.
59      !!              - All arguments of the above calling sequence are optional so their
60      !!                name must be explicitly typed if used. For instance if the mask
61      !!                array tmask(:,:,:) must be passed through the prt_ctl subroutine,
62      !!                it must looks like: CALL prt_ctl( mask=tmask ).
63      !!----------------------------------------------------------------------
64      REAL(wp)         , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d     ! 4D array
65      REAL(wp)         , DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask      ! 3D mask to apply to the tab4d array
66      CHARACTER (len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array
67      CHARACTER (len=*)                    , INTENT(in), OPTIONAL ::   clinfo2   ! ???
68      INTEGER                              , INTENT(in), OPTIONAL ::   ovlap     ! overlap value
69      INTEGER                              , INTENT(in), OPTIONAL ::   kdim      ! k- direction for 4D arrays
70      !!
71      INTEGER  ::   overlap, jn, js, sind, eind, kdir, j_id
72      REAL(wp) ::   zsum, zvctl
73      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask, ztab3d
74      CHARACTER (len=20), DIMENSION(jptra) ::   cl
75      CHARACTER (len=10) ::   cl2
76      !!----------------------------------------------------------------------
77
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   END SUBROUTINE prt_ctl_trc
154
155
156   SUBROUTINE prt_ctl_trc_info( clinfo )
157      !!----------------------------------------------------------------------
158      !!                     ***  ROUTINE prt_ctl_trc_info  ***
159      !!
160      !! ** Purpose : - print information without any computation
161      !!----------------------------------------------------------------------
162      CHARACTER (len=*), INTENT(in) ::   clinfo      ! information to print
163      !!
164      INTEGER ::   js, sind, eind, j_id
165      !!----------------------------------------------------------------------
166
167      IF( lk_mpp ) THEN      ! processor number
168         sind = narea
169         eind = narea
170      ELSE                   ! total number of processors
171         sind = 1
172         eind = ijsplt
173      ENDIF
174
175      ! Loop over each sub-domain, i.e. number of processors ijsplt
176      DO js = sind, eind
177         j_id = numid_trc(js - narea + 1)
178         WRITE(j_id,*) clinfo
179      END DO
180      !
181   END SUBROUTINE prt_ctl_trc_info
182
183
184   SUBROUTINE prt_ctl_trc_init
185      !!----------------------------------------------------------------------
186      !!                     ***  ROUTINE prt_ctl_trc_init  ***
187      !!
188      !! ** Purpose :   open ASCII files & compute indices
189      !!----------------------------------------------------------------------
190      INTEGER            ::   js, sind, eind, j_id
191      CHARACTER (len=31) :: clfile_out
192      CHARACTER (len=27) :: clb_name
193      CHARACTER (len=19) :: cl_run
194      !!----------------------------------------------------------------------
195
196      !                             ! Allocate arrays
197      ALLOCATE( nlditl (ijsplt) )
198      ALLOCATE( nldjtl (ijsplt) )
199      ALLOCATE( nleitl (ijsplt) )
200      ALLOCATE( nlejtl (ijsplt) )
201      ALLOCATE( nimpptl(ijsplt) )
202      ALLOCATE( njmpptl(ijsplt) )
203      ALLOCATE( nlcitl (ijsplt) )
204      ALLOCATE( nlcjtl (ijsplt) )
205      ALLOCATE( tra_ctl(jptra,ijsplt) )
206      ALLOCATE( ibonitl(ijsplt) )
207      ALLOCATE( ibonjtl(ijsplt) )
208
209      tra_ctl(:,:) = 0.e0           ! Initialization to zero
210
211      IF( lk_mpp ) THEN
212         sind = narea
213         eind = narea
214         clb_name = "('mpp.top.output_',I3.3)"
215         cl_run = 'MULTI processor run'
216         ! use indices for each area computed by mpp_init subroutine
217         nlditl(:) = nldit(:) 
218         nleitl(:) = nleit(:) 
219         nldjtl(:) = nldjt(:) 
220         nlejtl(:) = nlejt(:) 
221         !
222         nimpptl(:) = nimppt(:)
223         njmpptl(:) = njmppt(:)
224         !
225         nlcitl(:) = nlcit(:)
226         nlcjtl(:) = nlcjt(:)
227         !
228         ibonitl(:) = ibonit(:)
229         ibonjtl(:) = ibonjt(:)
230      ELSE
231         sind = 1
232         eind = ijsplt
233         clb_name = "('mono.top.output_',I3.3)"
234         cl_run   = 'MONO processor run '
235         ! compute indices for each area as done in mpp_init subroutine
236         CALL sub_dom
237      ENDIF
238
239      ALLOCATE( numid_trc(eind-sind+1) )
240
241      DO js = sind, eind
242         WRITE(clfile_out,FMT=clb_name) js-1
243         CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
244         j_id = numid_trc(js -narea + 1)
245         WRITE(j_id,*)
246         WRITE(j_id,*) '                 L O D Y C - I P S L'
247         WRITE(j_id,*) '                       N E M 0 '
248         WRITE(j_id,*) '            Ocean General Circulation Model'
249         WRITE(j_id,*) '               version TOP 1.0  (2005) '
250         WRITE(j_id,*)
251         WRITE(j_id,*) '                   PROC number: ', js
252         WRITE(j_id,*)
253         WRITE(j_id,FMT="(19x,a20)") cl_run
254
255         ! Print the SUM control indices
256         IF( .NOT. lsp_area )   THEN
257            IF ( lk_mpp )   THEN
258               nictls = nlditl(js) 
259               nictle = nleitl(js)
260               njctls = nldjtl(js)
261               njctle = nlejtl(js)
262            ELSE
263               nictls = nimpptl(js) + nlditl(js) - 1
264               nictle = nimpptl(js) + nleitl(js) - 1
265               njctls = njmpptl(js) + nldjtl(js) - 1
266               njctle = njmpptl(js) + nlejtl(js) - 1
267            ENDIF
268         ENDIF
269         WRITE(j_id,*) 
270         WRITE(j_id,*) 'prt_tra_ctl :  Sum control indices'
271         WRITE(j_id,*) '~~~~~~~'
272         WRITE(j_id,*)
273         WRITE(j_id,9000)'                                nlej   = ', nlejtl(js), '              '
274         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
275         WRITE(j_id,9001)'                  |                                       |'
276         WRITE(j_id,9001)'                  |                                       |'
277         WRITE(j_id,9001)'                  |                                       |'
278         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
279         WRITE(j_id,9002)'           nldi   = ', nlditl(js),  '                           nlei   = ', nleitl(js)
280         WRITE(j_id,9001)'                  |                                       |'
281         WRITE(j_id,9001)'                  |                                       |'
282         WRITE(j_id,9001)'                  |                                       |'
283         WRITE(j_id,9004)'  njmpp  = ',njmpptl(js),'   ------------- njctls = ', njctls, ' -------------'
284         WRITE(j_id,9003)'           nimpp  = ', nimpptl(js), '        nldj   = ', nldjtl(js), '              '
285         WRITE(j_id,*)
286         WRITE(j_id,*)
287
2889000     FORMAT(a41,i4.4,a14)
2899001     FORMAT(a59)
2909002     FORMAT(a20,i4.4,a36,i3.3)
2919003     FORMAT(a20,i4.4,a17,i4.4)
2929004     FORMAT(a11,i4.4,a26,i4.4,a14)
293      END DO
294      !
295   END SUBROUTINE prt_ctl_trc_init
296
297
298   SUBROUTINE sub_dom
299      !!----------------------------------------------------------------------
300      !!                  ***  ROUTINE sub_dom  ***
301      !!                   
302      !! ** Purpose :   Lay out the global domain over processors.
303      !!                CAUTION:
304      !!                This part has been extracted from the mpp_init
305      !!                subroutine and names of variables/arrays have been
306      !!                slightly changed to avoid confusion but the computation
307      !!                is exactly the same. Any modification about indices of
308      !!                each sub-domain in the mppini.F90 module should be reported
309      !!                here.
310      !!
311      !! ** Method  :   Global domain is distributed in smaller local domains.
312      !!                Periodic condition is a function of the local domain position
313      !!                (global boundary or neighbouring domain) and of the global
314      !!                periodic
315      !!                Type :         jperio global periodic condition
316      !!                               nperio local  periodic condition
317      !!
318      !! ** Action  : - set domain parameters
319      !!                    nimpp     : longitudinal index
320      !!                    njmpp     : latitudinal  index
321      !!                    nperio    : lateral condition type
322      !!                    narea     : number for local area
323      !!                    nlcil      : first dimension
324      !!                    nlcjl      : second dimension
325      !!                    nbondil    : mark for "east-west local boundary"
326      !!                    nbondjl    : mark for "north-south local boundary"
327      !!----------------------------------------------------------------------
328      INTEGER ::   ji, jj, js               ! dummy loop indices
329      INTEGER ::   ii, ij                   ! temporary integers
330      INTEGER ::   irestil, irestjl         !    "          "
331      INTEGER ::   ijpi  , ijpj, nlcil      ! temporary logical unit
332      INTEGER ::   nlcjl , nbondil, nbondjl
333      INTEGER ::   nrecil, nrecjl, nldil, nleil, nldjl, nlejl
334      REAL(wp) ::   zidom, zjdom            ! temporary scalars
335      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! temporary workspace
336      !!----------------------------------------------------------------------
337
338      ! Dimension arrays for subdomains
339      ! -------------------------------
340      !  Computation of local domain sizes ilcitl() ilcjtl()
341      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
342      !  The subdomains are squares leeser than or equal to the global
343      !  dimensions divided by the number of processors minus the overlap
344      !  array (cf. par_oce.F90).
345
346      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
347      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
348
349      ALLOCATE( ilcitl (isplt,jsplt) )
350      ALLOCATE( ilcjtl (isplt,jsplt) )
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      ALLOCATE( iimpptl(isplt,jsplt) )
391      ALLOCATE( ijmpptl(isplt,jsplt) )
392     
393      iimpptl(:,:) = 1
394      ijmpptl(:,:) = 1
395     
396      IF( isplt > 1 ) THEN
397         DO jj = 1, jsplt
398            DO ji = 2, isplt
399               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
400            END DO
401         END DO
402      ENDIF
403
404      IF( jsplt > 1 ) THEN
405         DO jj = 2, jsplt
406            DO ji = 1, isplt
407               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
408            END DO
409         END DO
410      ENDIF
411     
412      ! Subdomain description
413      ! ---------------------
414
415      DO js = 1, ijsplt
416         ii = 1 + MOD( js-1, isplt )
417         ij = 1 + (js-1) / isplt
418         nimpptl(js) = iimpptl(ii,ij)
419         njmpptl(js) = ijmpptl(ii,ij)
420         nlcitl (js) = ilcitl (ii,ij)     
421         nlcil       = nlcitl (js)     
422         nlcjtl (js) = ilcjtl (ii,ij)     
423         nlcjl       = nlcjtl (js)
424         nbondjl = -1                                    ! general case
425         IF( js   >  isplt          )   nbondjl = 0      ! first row of processor
426         IF( js   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
427         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
428         ibonjtl(js) = nbondjl
429         
430         nbondil = 0                                     !
431         IF( MOD( js, isplt ) == 1 )   nbondil = -1      !
432         IF( MOD( js, isplt ) == 0 )   nbondil =  1      !
433         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
434         ibonitl(js) = nbondil
435         
436         nldil =  1   + jpreci
437         nleil = nlcil - jpreci
438         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
439         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
440         nldjl =  1   + jprecj
441         nlejl = nlcjl - jprecj
442         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
443         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
444         nlditl(js) = nldil
445         nleitl(js) = nleil
446         nldjtl(js) = nldjl
447         nlejtl(js) = nlejl
448      END DO
449
450      DEALLOCATE( iimpptl )
451      DEALLOCATE( ijmpptl )
452      DEALLOCATE( ilcitl )
453      DEALLOCATE( ilcjtl )
454      !
455   END SUBROUTINE sub_dom
456 
457#else
458   !!----------------------------------------------------------------------
459   !!   Dummy module :                                    NO passive tracer
460   !!----------------------------------------------------------------------
461#endif
462 
463   !!----------------------------------------------------------------------
464   !! NEMO/TOP 3.3 , LOCEAN-IPSL (2010)
465   !! $Id$
466   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
467   !!======================================================================   
468END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.