source: NEMO/branches/2019/fix_sn_cfctl_ticket2328/src/TOP/prtctl_trc.F90 @ 11872

Last change on this file since 11872 was 11872, checked in by acc, 11 months ago

Branch 2019/fix_sn_cfctl_ticket2328. See #2328. Replacement of ln_ctl and activation of full functionality with
sn_cfctl structure. These changes rename structure components l_mppout and l_mpptop as l_prtctl and l_prttrc
and introduce l_glochk to activate former ln_ctl code in stpctl.F90 to perform global location of min and max
checks. Also added is l_allon which can be used to activate all output (much like the former ln_ctl). If l_allon
is .false. then l_config decides whether or not the suboptions are used.

   sn_cfctl%l_glochk = .FALSE.    ! Range sanity checks are local (F) or global (T). Set T for debugging only
   sn_cfctl%l_allon  = .FALSE.    ! IF T activate all options. If F deactivate all unless l_config is T
   sn_cfctl%l_config = .TRUE.     ! IF .true. then control which reports are written with the remaining options

Note, these changes pass SETTE tests but all references to ln_ctl need to be removed from the sette scripts.

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