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

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 2636

Last change on this file since 2636 was 2633, checked in by trackstand2, 13 years ago

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