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

source: branches/2016/dev_r7012_ROBUST5_CNRS/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 7041

Last change on this file since 7041 was 7041, checked in by cetlod, 8 years ago

ROBUST5_CNRS : implementation of part I of new TOP interface - 1st step -, see ticket #1782
  • Property svn:keywords set to Id
File size: 14.3 KB
RevLine 
[331]1MODULE prtctl_trc
[945]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
[331]18   USE oce_trc          ! ocean space and time domain variables
[3680]19   USE prtctl           ! print control for OPA
[331]20
21   IMPLICIT NONE
22   PRIVATE
23
[945]24   INTEGER , DIMENSION(:), ALLOCATABLE ::   numid_trc          !: logical unit
25   INTEGER , DIMENSION(:), ALLOCATABLE ::   nlditl , nldjtl    !: first, last indoor index for each i-domain
26   INTEGER , DIMENSION(:), ALLOCATABLE ::   nleitl , nlejtl    !: first, last indoor index for each j-domain
27   INTEGER , DIMENSION(:), ALLOCATABLE ::   nimpptl, njmpptl   !: i-, j-indexes for each processor
28   INTEGER , DIMENSION(:), ALLOCATABLE ::   nlcitl , nlcjtl    !: dimensions of every subdomain
29   INTEGER , DIMENSION(:), ALLOCATABLE ::   ibonitl, ibonjtl
[331]30
[945]31   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   tra_ctl         !: previous trend values
[331]32
33   PUBLIC prt_ctl_trc         ! called by all subroutines
34   PUBLIC prt_ctl_trc_info    !
35   PUBLIC prt_ctl_trc_init    ! called by opa.F90
[945]36
[331]37CONTAINS
38
[945]39   SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
[331]40      !!----------------------------------------------------------------------
41      !!                     ***  ROUTINE prt_ctl  ***
42      !!
43      !! ** Purpose : - print sum control 3D arrays over the same area
44      !!                in mono and mpp case. This way can be usefull when
45      !!                debugging a new parametrization in mono or mpp.
46      !!
47      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
48      !!                .true. in the ocean namelist:
49      !!              - to debug a MPI run .vs. a mono-processor one;
50      !!                the control print will be done over each sub-domain.
51      !!                The nictl[se] and njctl[se] parameters in the namelist must
52      !!                be set to zero and [ij]splt to the corresponding splitted
53      !!                domain in MPI along respectively i-, j- directions.
54      !!              - to debug a mono-processor run over the whole domain/a specific area;
55      !!                in the first case the nictl[se] and njctl[se] parameters must be set
56      !!                to zero else to the indices of the area to be controled. In both cases
57      !!                isplt and jsplt must be set to 1.
58      !!              - All arguments of the above calling sequence are optional so their
59      !!                name must be explicitly typed if used. For instance if the mask
60      !!                array tmask(:,:,:) must be passed through the prt_ctl subroutine,
[945]61      !!                it must looks like: CALL prt_ctl( mask=tmask ).
62      !!----------------------------------------------------------------------
63      REAL(wp)         , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d     ! 4D array
64      REAL(wp)         , DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask      ! 3D mask to apply to the tab4d array
65      CHARACTER (len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array
66      CHARACTER (len=*)                    , INTENT(in), OPTIONAL ::   clinfo2   ! ???
67      INTEGER                              , INTENT(in), OPTIONAL ::   ovlap     ! overlap value
68      INTEGER                              , INTENT(in), OPTIONAL ::   kdim      ! k- direction for 4D arrays
[331]69      !!
[945]70      INTEGER  ::   overlap, jn, js, sind, eind, kdir, j_id
71      REAL(wp) ::   zsum, zvctl
[7041]72      CHARACTER (len=20), ALLOCATABLE, DIMENSION(:) ::   cl
[945]73      CHARACTER (len=10) ::   cl2
[3294]74      REAL(wp), POINTER, DIMENSION(:,:,:)  :: zmask, ztab3d 
[331]75      !!----------------------------------------------------------------------
76
[3294]77      CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
[7041]78      ALLOCATE( cl(jptra) )
[945]79      !                                      ! Arrays, scalars initialization
[331]80      overlap       = 0
81      kdir          = jpkm1
82      zsum          = 0.e0
83      zvctl         = 0.e0
84      cl(:)         = ''
85      cl2           = ''
86      ztab3d(:,:,:) = 0.e0
87      zmask (:,:,:) = 1.e0
88
[945]89      !                                      ! Control of optional arguments
90      IF( PRESENT(ovlap)   )   overlap       = ovlap
91      IF( PRESENT(kdim)    )   kdir          = kdim
92      IF( PRESENT(clinfo ) )   cl(:)         = clinfo(:)
93      IF( PRESENT(clinfo2) )   cl2           = clinfo2
94      IF( PRESENT(mask)    )   zmask (:,:,:) = mask(:,:,:)
[331]95
[945]96      IF( lk_mpp )   THEN      ! processor number
[331]97         sind = narea
98         eind = narea
[945]99      ELSE                     ! processors total number
[331]100         sind = 1
101         eind = ijsplt
102      ENDIF
103
104      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
105      DO js = sind, eind
[945]106         !
[625]107         ! Set logical unit
[945]108         j_id = numid_trc( js - narea + 1 )
[331]109         ! Set indices for the SUM control
110         IF( .NOT. lsp_area ) THEN
111            IF (lk_mpp )   THEN
112               nictls = MAX( 1, nlditl(js) - overlap )
113               nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js)) 
114               njctls = MAX( 1, nldjtl(js) - overlap )
115               njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
116               ! Do not take into account the bound of the domain
[945]117               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
118               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nleitl(js) - 1 )
119               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
120               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, nlejtl(js) - 1 )
[331]121            ELSE
122               nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
123               nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) ) 
124               njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
125               njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) ) 
126               ! Do not take into account the bound of the domain
[945]127               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
128               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
129               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
130               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
[331]131            ENDIF
132         ENDIF
[945]133         !
[331]134         IF( PRESENT(clinfo2) ) THEN
135            DO jn = 1, jptra
136               zvctl  = tra_ctl(jn,js)
137               ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]138               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
139                  &                * zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]140               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
[331]141               tra_ctl(jn,js) = zsum
[945]142            END DO
[331]143         ELSE
144            DO jn = 1, jptra
145               ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]146               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
147                  &               *  zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]148               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
[331]149            END DO
150         ENDIF
[945]151         !
152      END DO
153      !
[3294]154      CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
[7041]155      DEALLOCATE( cl )
[2715]156      !
[945]157   END SUBROUTINE prt_ctl_trc
[331]158
159
[945]160   SUBROUTINE prt_ctl_trc_info( clinfo )
[331]161      !!----------------------------------------------------------------------
162      !!                     ***  ROUTINE prt_ctl_trc_info  ***
163      !!
164      !! ** Purpose : - print information without any computation
165      !!----------------------------------------------------------------------
[945]166      CHARACTER (len=*), INTENT(in) ::   clinfo      ! information to print
167      !!
168      INTEGER ::   js, sind, eind, j_id
[331]169      !!----------------------------------------------------------------------
170
[945]171      IF( lk_mpp ) THEN      ! processor number
[331]172         sind = narea
173         eind = narea
[945]174      ELSE                   ! total number of processors
[331]175         sind = 1
176         eind = ijsplt
177      ENDIF
178
179      ! Loop over each sub-domain, i.e. number of processors ijsplt
180      DO js = sind, eind
[627]181         j_id = numid_trc(js - narea + 1)
[945]182         WRITE(j_id,*) clinfo
183      END DO
184      !
185   END SUBROUTINE prt_ctl_trc_info
[331]186
187
188   SUBROUTINE prt_ctl_trc_init
189      !!----------------------------------------------------------------------
190      !!                     ***  ROUTINE prt_ctl_trc_init  ***
191      !!
192      !! ** Purpose :   open ASCII files & compute indices
193      !!----------------------------------------------------------------------
[945]194      INTEGER            ::   js, sind, eind, j_id
[331]195      CHARACTER (len=31) :: clfile_out
196      CHARACTER (len=27) :: clb_name
197      CHARACTER (len=19) :: cl_run
198      !!----------------------------------------------------------------------
199
[945]200      !                             ! Allocate arrays
201      ALLOCATE( nlditl (ijsplt) )
202      ALLOCATE( nldjtl (ijsplt) )
203      ALLOCATE( nleitl (ijsplt) )
204      ALLOCATE( nlejtl (ijsplt) )
205      ALLOCATE( nimpptl(ijsplt) )
206      ALLOCATE( njmpptl(ijsplt) )
207      ALLOCATE( nlcitl (ijsplt) )
208      ALLOCATE( nlcjtl (ijsplt) )
209      ALLOCATE( tra_ctl(jptra,ijsplt) )
210      ALLOCATE( ibonitl(ijsplt) )
211      ALLOCATE( ibonjtl(ijsplt) )
[331]212
[945]213      tra_ctl(:,:) = 0.e0           ! Initialization to zero
[331]214
215      IF( lk_mpp ) THEN
216         sind = narea
217         eind = narea
218         clb_name = "('mpp.top.output_',I3.3)"
219         cl_run = 'MULTI processor run'
220         ! use indices for each area computed by mpp_init subroutine
[4520]221         nlditl(1:jpnij) = nldit(:) 
222         nleitl(1:jpnij) = nleit(:) 
223         nldjtl(1:jpnij) = nldjt(:) 
224         nlejtl(1:jpnij) = nlejt(:) 
[331]225         !
[4520]226         nimpptl(1:jpnij) = nimppt(:)
227         njmpptl(1:jpnij) = njmppt(:)
[331]228         !
[4520]229         nlcitl(1:jpnij) = nlcit(:)
230         nlcjtl(1:jpnij) = nlcjt(:)
[331]231         !
[4520]232         ibonitl(1:jpnij) = ibonit(:)
233         ibonjtl(1:jpnij) = ibonjt(:)
[331]234      ELSE
235         sind = 1
236         eind = ijsplt
237         clb_name = "('mono.top.output_',I3.3)"
[945]238         cl_run   = 'MONO processor run '
[331]239         ! compute indices for each area as done in mpp_init subroutine
240         CALL sub_dom
241      ENDIF
242
[945]243      ALLOCATE( numid_trc(eind-sind+1) )
[625]244
[331]245      DO js = sind, eind
246         WRITE(clfile_out,FMT=clb_name) js-1
[1581]247         CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
[627]248         j_id = numid_trc(js -narea + 1)
249         WRITE(j_id,*)
250         WRITE(j_id,*) '                 L O D Y C - I P S L'
[945]251         WRITE(j_id,*) '                       N E M 0 '
[627]252         WRITE(j_id,*) '            Ocean General Circulation Model'
[945]253         WRITE(j_id,*) '               version TOP 1.0  (2005) '
[627]254         WRITE(j_id,*)
255         WRITE(j_id,*) '                   PROC number: ', js
256         WRITE(j_id,*)
[945]257         WRITE(j_id,FMT="(19x,a20)") cl_run
[331]258
259         ! Print the SUM control indices
260         IF( .NOT. lsp_area )   THEN
261            IF ( lk_mpp )   THEN
262               nictls = nlditl(js) 
263               nictle = nleitl(js)
264               njctls = nldjtl(js)
265               njctle = nlejtl(js)
266            ELSE
267               nictls = nimpptl(js) + nlditl(js) - 1
268               nictle = nimpptl(js) + nleitl(js) - 1
269               njctls = njmpptl(js) + nldjtl(js) - 1
270               njctle = njmpptl(js) + nlejtl(js) - 1
271            ENDIF
272         ENDIF
[627]273         WRITE(j_id,*) 
274         WRITE(j_id,*) 'prt_tra_ctl :  Sum control indices'
275         WRITE(j_id,*) '~~~~~~~'
276         WRITE(j_id,*)
277         WRITE(j_id,9000)'                                nlej   = ', nlejtl(js), '              '
278         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
279         WRITE(j_id,9001)'                  |                                       |'
280         WRITE(j_id,9001)'                  |                                       |'
281         WRITE(j_id,9001)'                  |                                       |'
282         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
283         WRITE(j_id,9002)'           nldi   = ', nlditl(js),  '                           nlei   = ', nleitl(js)
284         WRITE(j_id,9001)'                  |                                       |'
285         WRITE(j_id,9001)'                  |                                       |'
286         WRITE(j_id,9001)'                  |                                       |'
287         WRITE(j_id,9004)'  njmpp  = ',njmpptl(js),'   ------------- njctls = ', njctls, ' -------------'
288         WRITE(j_id,9003)'           nimpp  = ', nimpptl(js), '        nldj   = ', nldjtl(js), '              '
289         WRITE(j_id,*)
290         WRITE(j_id,*)
[331]291
2929000     FORMAT(a41,i4.4,a14)
2939001     FORMAT(a59)
2949002     FORMAT(a20,i4.4,a36,i3.3)
2959003     FORMAT(a20,i4.4,a17,i4.4)
2969004     FORMAT(a11,i4.4,a26,i4.4,a14)
[945]297      END DO
298      !
[331]299   END SUBROUTINE prt_ctl_trc_init
300
301#else
302   !!----------------------------------------------------------------------
[945]303   !!   Dummy module :                                    NO passive tracer
[331]304   !!----------------------------------------------------------------------
305#endif
[2528]306 
307   !!----------------------------------------------------------------------
308   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
309   !! $Id$
310   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
311   !!======================================================================   
[331]312END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.