source: branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 7953

Last change on this file since 7953 was 7881, checked in by cetlod, 4 years ago

trunk: minor corrections to be able to compile and run ORCA2_LIM3 configuration referenced to ORCA2_LIM3_PISCES

  • 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  ***
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 ln_ctl 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 subroutine,
57      !!                it must looks like: CALL prt_ctl( 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), POINTER, DIMENSION(:,:,:)  :: zmask, ztab3d 
71      !!----------------------------------------------------------------------
72
73      CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
74      ALLOCATE( cl(jptra) )
75      !                                      ! Arrays, scalars initialization
76      overlap       = 0
77      kdir          = jpkm1
78      zsum          = 0.e0
79      zvctl         = 0.e0
80      cl(:)         = ''
81      cl2           = ''
82      ztab3d(:,:,:) = 0.e0
83      zmask (:,:,:) = 1.e0
84
85      !                                      ! Control of optional arguments
86      IF( PRESENT(ovlap)   )   overlap       = ovlap
87      IF( PRESENT(kdim)    )   kdir          = kdim
88      IF( PRESENT(clinfo ) )   cl(:)         = clinfo(:)
89      IF( PRESENT(clinfo2) )   cl2           = clinfo2
90      IF( PRESENT(mask)    )   zmask (:,:,:) = mask(:,:,:)
91
92      IF( lk_mpp )   THEN      ! processor number
93         sind = narea
94         eind = narea
95      ELSE                     ! processors total number
96         sind = 1
97         eind = ijsplt
98      ENDIF
99
100      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
101      DO js = sind, eind
102         !
103         ! Set logical unit
104         j_id = numid_trc( js - narea + 1 )
105         ! Set indices for the SUM control
106         IF( .NOT. lsp_area ) THEN
107            IF (lk_mpp )   THEN
108               nictls = MAX( 1, nlditl(js) - overlap )
109               nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js)) 
110               njctls = MAX( 1, nldjtl(js) - overlap )
111               njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
112               ! Do not take into account the bound of the domain
113               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
114               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nleitl(js) - 1 )
115               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
116               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, nlejtl(js) - 1 )
117            ELSE
118               nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
119               nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) ) 
120               njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
121               njctle = njmpptl(js) + nlejtl(js) - 1 + 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( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
125               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
126               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
127            ENDIF
128         ENDIF
129         !
130         IF( PRESENT(clinfo2) ) THEN
131            DO jn = 1, jptra
132               zvctl  = tra_ctl(jn,js)
133               ztab3d(:,:,:) = tab4d(:,:,:,jn)
134               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
135                  &                * zmask(nictls:nictle,njctls:njctle,1:kdir) )
136               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
137               tra_ctl(jn,js) = zsum
138            END DO
139         ELSE
140            DO jn = 1, jptra
141               ztab3d(:,:,:) = tab4d(:,:,:,jn)
142               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
143                  &               *  zmask(nictls:nictle,njctls:njctle,1:kdir) )
144               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
145            END DO
146         ENDIF
147         !
148      END DO
149      !
150      CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
151      DEALLOCATE( cl )
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(1:jpnij) = nldit(:) 
218         nleitl(1:jpnij) = nleit(:) 
219         nldjtl(1:jpnij) = nldjt(:) 
220         nlejtl(1:jpnij) = nlejt(:) 
221         !
222         nimpptl(1:jpnij) = nimppt(:)
223         njmpptl(1:jpnij) = njmppt(:)
224         !
225         nlcitl(1:jpnij) = nlcit(:)
226         nlcjtl(1:jpnij) = nlcjt(:)
227         !
228         ibonitl(1:jpnij) = ibonit(:)
229         ibonjtl(1:jpnij) = 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
297END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.