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
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), ALLOCATABLE, DIMENSION(:) ::   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      ALLOCATE( cl(jptra) )
79      !                                      ! Arrays, scalars initialization
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
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(:,:,:)
95
96      IF( lk_mpp )   THEN      ! processor number
97         sind = narea
98         eind = narea
99      ELSE                     ! processors total number
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
106         !
107         ! Set logical unit
108         j_id = numid_trc( js - narea + 1 )
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
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 )
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
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 )
131            ENDIF
132         ENDIF
133         !
134         IF( PRESENT(clinfo2) ) THEN
135            DO jn = 1, jptra
136               zvctl  = tra_ctl(jn,js)
137               ztab3d(:,:,:) = tab4d(:,:,:,jn)
138               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
139                  &                * zmask(nictls:nictle,njctls:njctle,1:kdir) )
140               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
141               tra_ctl(jn,js) = zsum
142            END DO
143         ELSE
144            DO jn = 1, jptra
145               ztab3d(:,:,:) = tab4d(:,:,:,jn)
146               zsum          = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir)   &
147                  &               *  zmask(nictls:nictle,njctls:njctle,1:kdir) )
148               WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
149            END DO
150         ENDIF
151         !
152      END DO
153      !
154      CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
155      DEALLOCATE( cl )
156      !
157   END SUBROUTINE prt_ctl_trc
158
159
160   SUBROUTINE prt_ctl_trc_info( clinfo )
161      !!----------------------------------------------------------------------
162      !!                     ***  ROUTINE prt_ctl_trc_info  ***
163      !!
164      !! ** Purpose : - print information without any computation
165      !!----------------------------------------------------------------------
166      CHARACTER (len=*), INTENT(in) ::   clinfo      ! information to print
167      !!
168      INTEGER ::   js, sind, eind, j_id
169      !!----------------------------------------------------------------------
170
171      IF( lk_mpp ) THEN      ! processor number
172         sind = narea
173         eind = narea
174      ELSE                   ! total number of processors
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
181         j_id = numid_trc(js - narea + 1)
182         WRITE(j_id,*) clinfo
183      END DO
184      !
185   END SUBROUTINE prt_ctl_trc_info
186
187
188   SUBROUTINE prt_ctl_trc_init
189      !!----------------------------------------------------------------------
190      !!                     ***  ROUTINE prt_ctl_trc_init  ***
191      !!
192      !! ** Purpose :   open ASCII files & compute indices
193      !!----------------------------------------------------------------------
194      INTEGER            ::   js, sind, eind, j_id
195      CHARACTER (len=31) :: clfile_out
196      CHARACTER (len=27) :: clb_name
197      CHARACTER (len=19) :: cl_run
198      !!----------------------------------------------------------------------
199
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) )
212
213      tra_ctl(:,:) = 0.e0           ! Initialization to zero
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
221         nlditl(1:jpnij) = nldit(:) 
222         nleitl(1:jpnij) = nleit(:) 
223         nldjtl(1:jpnij) = nldjt(:) 
224         nlejtl(1:jpnij) = nlejt(:) 
225         !
226         nimpptl(1:jpnij) = nimppt(:)
227         njmpptl(1:jpnij) = njmppt(:)
228         !
229         nlcitl(1:jpnij) = nlcit(:)
230         nlcjtl(1:jpnij) = nlcjt(:)
231         !
232         ibonitl(1:jpnij) = ibonit(:)
233         ibonjtl(1:jpnij) = ibonjt(:)
234      ELSE
235         sind = 1
236         eind = ijsplt
237         clb_name = "('mono.top.output_',I3.3)"
238         cl_run   = 'MONO processor run '
239         ! compute indices for each area as done in mpp_init subroutine
240         CALL sub_dom
241      ENDIF
242
243      ALLOCATE( numid_trc(eind-sind+1) )
244
245      DO js = sind, eind
246         WRITE(clfile_out,FMT=clb_name) js-1
247         CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
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'
251         WRITE(j_id,*) '                       N E M 0 '
252         WRITE(j_id,*) '            Ocean General Circulation Model'
253         WRITE(j_id,*) '               version TOP 1.0  (2005) '
254         WRITE(j_id,*)
255         WRITE(j_id,*) '                   PROC number: ', js
256         WRITE(j_id,*)
257         WRITE(j_id,FMT="(19x,a20)") cl_run
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
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,*)
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)
297      END DO
298      !
299   END SUBROUTINE prt_ctl_trc_init
300
301#else
302   !!----------------------------------------------------------------------
303   !!   Dummy module :                                    NO passive tracer
304   !!----------------------------------------------------------------------
305#endif
306 
307   !!----------------------------------------------------------------------
308   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
309   !! $Id$
310   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
311   !!======================================================================   
312END MODULE prtctl_trc
Note: See TracBrowser for help on using the repository browser.