source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 10149

Last change on this file since 10149 was 6486, checked in by davestorkey, 5 years ago

Remove SVN keywords from UKMO/dev_r5518_GO6_package branch.

File size: 14.2 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 prtctl           ! print control for OPA
20
21   IMPLICIT NONE
22   PRIVATE
23
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
30
31   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   tra_ctl         !: previous trend values
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
36
37CONTAINS
38
39   SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
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,
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
69      !!
70      INTEGER  ::   overlap, jn, js, sind, eind, kdir, j_id
71      REAL(wp) ::   zsum, zvctl
72      CHARACTER (len=20), DIMENSION(jptra) ::   cl
73      CHARACTER (len=10) ::   cl2
74      REAL(wp), POINTER, DIMENSION(:,:,:)  :: zmask, ztab3d 
75      !!----------------------------------------------------------------------
76
77      CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
78      !                                      ! Arrays, scalars initialization
79      overlap       = 0
80      kdir          = jpkm1
81      zsum          = 0.e0
82      zvctl         = 0.e0
83      cl(:)         = ''
84      cl2           = ''
85      ztab3d(:,:,:) = 0.e0
86      zmask (:,:,:) = 1.e0
87
88      !                                      ! Control of optional arguments
89      IF( PRESENT(ovlap)   )   overlap       = ovlap
90      IF( PRESENT(kdim)    )   kdir          = kdim
91      IF( PRESENT(clinfo ) )   cl(:)         = clinfo(:)
92      IF( PRESENT(clinfo2) )   cl2           = clinfo2
93      IF( PRESENT(mask)    )   zmask (:,:,:) = mask(:,:,:)
94
95      IF( lk_mpp )   THEN      ! processor number
96         sind = narea
97         eind = narea
98      ELSE                     ! processors total number
99         sind = 1
100         eind = ijsplt
101      ENDIF
102
103      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
104      DO js = sind, eind
105         !
106         ! Set logical unit
107         j_id = numid_trc( js - narea + 1 )
108         ! Set indices for the SUM control
109         IF( .NOT. lsp_area ) THEN
110            IF (lk_mpp )   THEN
111               nictls = MAX( 1, nlditl(js) - overlap )
112               nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js)) 
113               njctls = MAX( 1, nldjtl(js) - overlap )
114               njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
115               ! Do not take into account the bound of the domain
116               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
117               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nleitl(js) - 1 )
118               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
119               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, nlejtl(js) - 1 )
120            ELSE
121               nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
122               nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) ) 
123               njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
124               njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) ) 
125               ! Do not take into account the bound of the domain
126               IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 )   nictls = MAX( 2, nictls )
127               IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 )   njctls = MAX( 2, njctls )
128               IF( ibonitl(js) ==  1 .OR. ibonitl(js) == 2 )   nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
129               IF( ibonjtl(js) ==  1 .OR. ibonjtl(js) == 2 )   njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
130            ENDIF
131         ENDIF
132         !
133         IF( PRESENT(clinfo2) ) THEN
134            DO jn = 1, jptra
135               zvctl  = tra_ctl(jn,js)
136               ztab3d(:,:,:) = tab4d(:,:,:,jn)
137               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
138                  &                * zmask(nictls:nictle,njctls:njctle,1:kdir) )
139               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
140               tra_ctl(jn,js) = zsum
141            END DO
142         ELSE
143            DO jn = 1, jptra
144               ztab3d(:,:,:) = tab4d(:,:,:,jn)
145               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
146                  &               *  zmask(nictls:nictle,njctls:njctle,1:kdir) )
147               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
148            END DO
149         ENDIF
150         !
151      END DO
152      !
153      CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
154      !
155   END SUBROUTINE prt_ctl_trc
156
157
158   SUBROUTINE prt_ctl_trc_info( clinfo )
159      !!----------------------------------------------------------------------
160      !!                     ***  ROUTINE prt_ctl_trc_info  ***
161      !!
162      !! ** Purpose : - print information without any computation
163      !!----------------------------------------------------------------------
164      CHARACTER (len=*), INTENT(in) ::   clinfo      ! information to print
165      !!
166      INTEGER ::   js, sind, eind, j_id
167      !!----------------------------------------------------------------------
168
169      IF( lk_mpp ) THEN      ! processor number
170         sind = narea
171         eind = narea
172      ELSE                   ! total number of processors
173         sind = 1
174         eind = ijsplt
175      ENDIF
176
177      ! Loop over each sub-domain, i.e. number of processors ijsplt
178      DO js = sind, eind
179         j_id = numid_trc(js - narea + 1)
180         WRITE(j_id,*) clinfo
181      END DO
182      !
183   END SUBROUTINE prt_ctl_trc_info
184
185
186   SUBROUTINE prt_ctl_trc_init
187      !!----------------------------------------------------------------------
188      !!                     ***  ROUTINE prt_ctl_trc_init  ***
189      !!
190      !! ** Purpose :   open ASCII files & compute indices
191      !!----------------------------------------------------------------------
192      INTEGER            ::   js, sind, eind, j_id
193      CHARACTER (len=31) :: clfile_out
194      CHARACTER (len=27) :: clb_name
195      CHARACTER (len=19) :: cl_run
196      !!----------------------------------------------------------------------
197
198      !                             ! Allocate arrays
199      ALLOCATE( nlditl (ijsplt) )
200      ALLOCATE( nldjtl (ijsplt) )
201      ALLOCATE( nleitl (ijsplt) )
202      ALLOCATE( nlejtl (ijsplt) )
203      ALLOCATE( nimpptl(ijsplt) )
204      ALLOCATE( njmpptl(ijsplt) )
205      ALLOCATE( nlcitl (ijsplt) )
206      ALLOCATE( nlcjtl (ijsplt) )
207      ALLOCATE( tra_ctl(jptra,ijsplt) )
208      ALLOCATE( ibonitl(ijsplt) )
209      ALLOCATE( ibonjtl(ijsplt) )
210
211      tra_ctl(:,:) = 0.e0           ! Initialization to zero
212
213      IF( lk_mpp ) THEN
214         sind = narea
215         eind = narea
216         clb_name = "('mpp.top.output_',I3.3)"
217         cl_run = 'MULTI processor run'
218         ! use indices for each area computed by mpp_init subroutine
219         nlditl(1:jpnij) = nldit(:) 
220         nleitl(1:jpnij) = nleit(:) 
221         nldjtl(1:jpnij) = nldjt(:) 
222         nlejtl(1:jpnij) = nlejt(:) 
223         !
224         nimpptl(1:jpnij) = nimppt(:)
225         njmpptl(1:jpnij) = njmppt(:)
226         !
227         nlcitl(1:jpnij) = nlcit(:)
228         nlcjtl(1:jpnij) = nlcjt(:)
229         !
230         ibonitl(1:jpnij) = ibonit(:)
231         ibonjtl(1:jpnij) = ibonjt(:)
232      ELSE
233         sind = 1
234         eind = ijsplt
235         clb_name = "('mono.top.output_',I3.3)"
236         cl_run   = 'MONO processor run '
237         ! compute indices for each area as done in mpp_init subroutine
238         CALL sub_dom
239      ENDIF
240
241      ALLOCATE( numid_trc(eind-sind+1) )
242
243      DO js = sind, eind
244         WRITE(clfile_out,FMT=clb_name) js-1
245         CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
246         j_id = numid_trc(js -narea + 1)
247         WRITE(j_id,*)
248         WRITE(j_id,*) '                 L O D Y C - I P S L'
249         WRITE(j_id,*) '                       N E M 0 '
250         WRITE(j_id,*) '            Ocean General Circulation Model'
251         WRITE(j_id,*) '               version TOP 1.0  (2005) '
252         WRITE(j_id,*)
253         WRITE(j_id,*) '                   PROC number: ', js
254         WRITE(j_id,*)
255         WRITE(j_id,FMT="(19x,a20)") cl_run
256
257         ! Print the SUM control indices
258         IF( .NOT. lsp_area )   THEN
259            IF ( lk_mpp )   THEN
260               nictls = nlditl(js) 
261               nictle = nleitl(js)
262               njctls = nldjtl(js)
263               njctle = nlejtl(js)
264            ELSE
265               nictls = nimpptl(js) + nlditl(js) - 1
266               nictle = nimpptl(js) + nleitl(js) - 1
267               njctls = njmpptl(js) + nldjtl(js) - 1
268               njctle = njmpptl(js) + nlejtl(js) - 1
269            ENDIF
270         ENDIF
271         WRITE(j_id,*) 
272         WRITE(j_id,*) 'prt_tra_ctl :  Sum control indices'
273         WRITE(j_id,*) '~~~~~~~'
274         WRITE(j_id,*)
275         WRITE(j_id,9000)'                                nlej   = ', nlejtl(js), '              '
276         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
277         WRITE(j_id,9001)'                  |                                       |'
278         WRITE(j_id,9001)'                  |                                       |'
279         WRITE(j_id,9001)'                  |                                       |'
280         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
281         WRITE(j_id,9002)'           nldi   = ', nlditl(js),  '                           nlei   = ', nleitl(js)
282         WRITE(j_id,9001)'                  |                                       |'
283         WRITE(j_id,9001)'                  |                                       |'
284         WRITE(j_id,9001)'                  |                                       |'
285         WRITE(j_id,9004)'  njmpp  = ',njmpptl(js),'   ------------- njctls = ', njctls, ' -------------'
286         WRITE(j_id,9003)'           nimpp  = ', nimpptl(js), '        nldj   = ', nldjtl(js), '              '
287         WRITE(j_id,*)
288         WRITE(j_id,*)
289
2909000     FORMAT(a41,i4.4,a14)
2919001     FORMAT(a59)
2929002     FORMAT(a20,i4.4,a36,i3.3)
2939003     FORMAT(a20,i4.4,a17,i4.4)
2949004     FORMAT(a11,i4.4,a26,i4.4,a14)
295      END DO
296      !
297   END SUBROUTINE prt_ctl_trc_init
298
299#else
300   !!----------------------------------------------------------------------
301   !!   Dummy module :                                    NO passive tracer
302   !!----------------------------------------------------------------------
303#endif
304 
305   !!----------------------------------------------------------------------
306   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
307   !! $Id$
308   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
309   !!======================================================================   
310END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.