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

source: branches/dev_001_GM/NEMO/TOP_SRC/prtctl_trc.F90 @ 763

Last change on this file since 763 was 763, checked in by gm, 16 years ago

dev_001_GM - Style only addition in TOP F90 h90 routines

  • 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_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_passivetrc
10   !!----------------------------------------------------------------------
11   !!   'key_passivetrc'                                    Passive tracers
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_trp      ! ???
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   !! $Header:$
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 ctlopn( numid_trc(js -narea + 1), clfile_out, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL',   &
250            &         1, numout, .FALSE., 1 )
251         j_id = numid_trc(js -narea + 1)
252         WRITE(j_id,*)
253         WRITE(j_id,*) '                 L O D Y C - I P S L'
254         WRITE(j_id,*) '                       N E M 0 '
255         WRITE(j_id,*) '            Ocean General Circulation Model'
256         WRITE(j_id,*) '               version TOP 1.0  (2005) '
257         WRITE(j_id,*)
258         WRITE(j_id,*) '                   PROC number: ', js
259         WRITE(j_id,*)
260         WRITE(j_id,FMT="(19x,a20)") cl_run
261
262         ! Print the SUM control indices
263         IF( .NOT. lsp_area )   THEN
264            IF ( lk_mpp )   THEN
265               nictls = nlditl(js) 
266               nictle = nleitl(js)
267               njctls = nldjtl(js)
268               njctle = nlejtl(js)
269            ELSE
270               nictls = nimpptl(js) + nlditl(js) - 1
271               nictle = nimpptl(js) + nleitl(js) - 1
272               njctls = njmpptl(js) + nldjtl(js) - 1
273               njctle = njmpptl(js) + nlejtl(js) - 1
274            ENDIF
275         ENDIF
276         WRITE(j_id,*) 
277         WRITE(j_id,*) 'prt_tra_ctl :  Sum control indices'
278         WRITE(j_id,*) '~~~~~~~'
279         WRITE(j_id,*)
280         WRITE(j_id,9000)'                                nlej   = ', nlejtl(js), '              '
281         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
282         WRITE(j_id,9001)'                  |                                       |'
283         WRITE(j_id,9001)'                  |                                       |'
284         WRITE(j_id,9001)'                  |                                       |'
285         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
286         WRITE(j_id,9002)'           nldi   = ', nlditl(js),  '                           nlei   = ', nleitl(js)
287         WRITE(j_id,9001)'                  |                                       |'
288         WRITE(j_id,9001)'                  |                                       |'
289         WRITE(j_id,9001)'                  |                                       |'
290         WRITE(j_id,9004)'  njmpp  = ',njmpptl(js),'   ------------- njctls = ', njctls, ' -------------'
291         WRITE(j_id,9003)'           nimpp  = ', nimpptl(js), '        nldj   = ', nldjtl(js), '              '
292         WRITE(j_id,*)
293         WRITE(j_id,*)
294
2959000     FORMAT(a41,i4.4,a14)
2969001     FORMAT(a59)
2979002     FORMAT(a20,i4.4,a36,i3.3)
2989003     FORMAT(a20,i4.4,a17,i4.4)
2999004     FORMAT(a11,i4.4,a26,i4.4,a14)
300      END DO
301      !
302   END SUBROUTINE prt_ctl_trc_init
303
304
305   SUBROUTINE sub_dom
306      !!----------------------------------------------------------------------
307      !!                  ***  ROUTINE sub_dom  ***
308      !!                   
309      !! ** Purpose :   Lay out the global domain over processors.
310      !!                CAUTION:
311      !!                This part has been extracted from the mpp_init
312      !!                subroutine and names of variables/arrays have been
313      !!                slightly changed to avoid confusion but the computation
314      !!                is exactly the same. Any modification about indices of
315      !!                each sub-domain in the mppini.F90 module should be reported
316      !!                here.
317      !!
318      !! ** Method  :   Global domain is distributed in smaller local domains.
319      !!                Periodic condition is a function of the local domain position
320      !!                (global boundary or neighbouring domain) and of the global
321      !!                periodic
322      !!                Type :         jperio global periodic condition
323      !!                               nperio local  periodic condition
324      !!
325      !! ** Action  : - set domain parameters
326      !!                    nimpp     : longitudinal index
327      !!                    njmpp     : latitudinal  index
328      !!                    nperio    : lateral condition type
329      !!                    narea     : number for local area
330      !!                    nlcil      : first dimension
331      !!                    nlcjl      : second dimension
332      !!                    nbondil    : mark for "east-west local boundary"
333      !!                    nbondjl    : mark for "north-south local boundary"
334      !!----------------------------------------------------------------------
335      INTEGER ::   ji, jj, js               ! dummy loop indices
336      INTEGER ::   ii, ij                   ! temporary integers
337      INTEGER ::   irestil, irestjl         !    "          "
338      INTEGER ::   ijpi  , ijpj, nlcil      ! temporary logical unit
339      INTEGER ::   nlcjl , nbondil, nbondjl
340      INTEGER ::   nrecil, nrecjl, nldil, nleil, nldjl, nlejl
341      REAL(wp) ::   zidom, zjdom            ! temporary scalars
342      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! temporary workspace
343      !!----------------------------------------------------------------------
344
345      ! Dimension arrays for subdomains
346      ! -------------------------------
347      !  Computation of local domain sizes ilcitl() ilcjtl()
348      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
349      !  The subdomains are squares leeser than or equal to the global
350      !  dimensions divided by the number of processors minus the overlap
351      !  array (cf. par_oce.F90).
352
353      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
354      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
355
356      ALLOCATE( ilcitl (isplt,jsplt) )
357      ALLOCATE( ilcjtl (isplt,jsplt) )
358
359      nrecil  = 2 * jpreci
360      nrecjl  = 2 * jprecj
361      irestil = MOD( jpiglo - nrecil , isplt )
362      irestjl = MOD( jpjglo - nrecjl , jsplt )
363
364      IF(  irestil == 0 )   irestil = isplt
365      DO jj = 1, jsplt
366         DO ji = 1, irestil
367            ilcitl(ji,jj) = ijpi
368         END DO
369         DO ji = irestil+1, isplt
370            ilcitl(ji,jj) = ijpi -1
371         END DO
372      END DO
373     
374      IF( irestjl == 0 )   irestjl = jsplt
375      DO ji = 1, isplt
376         DO jj = 1, irestjl
377            ilcjtl(ji,jj) = ijpj
378         END DO
379         DO jj = irestjl+1, jsplt
380            ilcjtl(ji,jj) = ijpj -1
381         END DO
382      END DO
383     
384      zidom = nrecil
385      DO ji = 1, isplt
386         zidom = zidom + ilcitl(ji,1) - nrecil
387      END DO
388     
389      zjdom = nrecjl
390      DO jj = 1, jsplt
391         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
392      END DO
393
394      ! Index arrays for subdomains
395      ! ---------------------------
396
397      ALLOCATE( iimpptl(isplt,jsplt) )
398      ALLOCATE( ijmpptl(isplt,jsplt) )
399     
400      iimpptl(:,:) = 1
401      ijmpptl(:,:) = 1
402     
403      IF( isplt > 1 ) THEN
404         DO jj = 1, jsplt
405            DO ji = 2, isplt
406               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
407            END DO
408         END DO
409      ENDIF
410
411      IF( jsplt > 1 ) THEN
412         DO jj = 2, jsplt
413            DO ji = 1, isplt
414               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
415            END DO
416         END DO
417      ENDIF
418     
419      ! Subdomain description
420      ! ---------------------
421
422      DO js = 1, ijsplt
423         ii = 1 + MOD( js-1, isplt )
424         ij = 1 + (js-1) / isplt
425         nimpptl(js) = iimpptl(ii,ij)
426         njmpptl(js) = ijmpptl(ii,ij)
427         nlcitl (js) = ilcitl (ii,ij)     
428         nlcil       = nlcitl (js)     
429         nlcjtl (js) = ilcjtl (ii,ij)     
430         nlcjl       = nlcjtl (js)
431         nbondjl = -1                                    ! general case
432         IF( js   >  isplt          )   nbondjl = 0      ! first row of processor
433         IF( js   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
434         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
435         ibonjtl(js) = nbondjl
436         
437         nbondil = 0                                     !
438         IF( MOD( js, isplt ) == 1 )   nbondil = -1      !
439         IF( MOD( js, isplt ) == 0 )   nbondil =  1      !
440         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
441         ibonitl(js) = nbondil
442         
443         nldil =  1   + jpreci
444         nleil = nlcil - jpreci
445         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
446         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
447         nldjl =  1   + jprecj
448         nlejl = nlcjl - jprecj
449         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
450         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
451         nlditl(js) = nldil
452         nleitl(js) = nleil
453         nldjtl(js) = nldjl
454         nlejtl(js) = nlejl
455      END DO
456
457      DEALLOCATE( iimpptl )
458      DEALLOCATE( ijmpptl )
459      DEALLOCATE( ilcitl )
460      DEALLOCATE( ilcjtl )
461      !
462   END SUBROUTINE sub_dom
463 
464#else
465   !!----------------------------------------------------------------------
466   !!   Dummy module :                                    NO passive tracer
467   !!----------------------------------------------------------------------
468#endif
469   
470   !!======================================================================
471END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.