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.F90 in NEMO/trunk/src/OCE/IOM – NEMO

source: NEMO/trunk/src/OCE/IOM/prtctl.F90 @ 14072

Last change on this file since 14072 was 14072, checked in by laurent, 3 years ago

Merging branch "2020/dev_r13648_ASINTER-04_laurent_bulk_ice", ticket #2369

  • Property svn:keywords set to Id
File size: 23.9 KB
Line 
1MODULE prtctl
2   !!======================================================================
3   !!                       ***  MODULE prtctl   ***
4   !! Ocean system : print all SUM trends for each processor domain
5   !!======================================================================
6   !! History :  9.0  !  05-07  (C. Talandier) original code
7   !!            3.4  !  11-11  (C. Harris) decomposition changes for running with CICE
8   !!----------------------------------------------------------------------
9   USE dom_oce          ! ocean space and time domain variables
10   USE domutl, ONLY : is_tile
11   USE in_out_manager   ! I/O manager
12   USE mppini           ! distributed memory computing
13   USE lib_mpp          ! distributed memory computing
14
15   IMPLICIT NONE
16   PRIVATE
17
18   INTEGER , DIMENSION(  :), ALLOCATABLE ::   numprt_oce, numprt_top
19   INTEGER , DIMENSION(  :), ALLOCATABLE ::   nall_ictls, nall_ictle   ! first, last indoor index for each i-domain
20   INTEGER , DIMENSION(  :), ALLOCATABLE ::   nall_jctls, nall_jctle   ! first, last indoor index for each j-domain
21   REAL(wp), DIMENSION(  :), ALLOCATABLE ::   t_ctl , s_ctl            ! previous tracer trend values
22   REAL(wp), DIMENSION(  :), ALLOCATABLE ::   u_ctl , v_ctl            ! previous velocity trend values
23   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   tra_ctl                  ! previous top trend values
24   !
25   PUBLIC prt_ctl         ! called by all subroutines
26   PUBLIC prt_ctl_info    ! called by all subroutines
27   PUBLIC prt_ctl_init    ! called by nemogcm.F90 and prt_ctl_trc_init
28
29   !! * Substitutions
30#  include "do_loop_substitute.h90"
31   !!----------------------------------------------------------------------
32   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
33   !! $Id$
34   !! Software governed by the CeCILL license (see ./LICENSE)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2,   &
39      &                 clinfo, clinfo1, clinfo2, clinfo3, kdim )
40      !!
41      REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_1
42      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_1
43      REAL(wp),         DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d_1
44      REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_2
45      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_2
46      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask1
47      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask2
48      CHARACTER(len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array
49      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo1
50      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo2
51      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo3
52      INTEGER                             , INTENT(in), OPTIONAL ::   kdim
53      !
54      INTEGER :: itab2d_1, itab3d_1, itab4d_1, itab2d_2, itab3d_2
55      !!
56      IF( PRESENT(tab2d_1)  ) THEN ; itab2d_1 = is_tile(tab2d_1)  ; ELSE ; itab2d_1 = 0 ; ENDIF
57      IF( PRESENT(tab3d_1)  ) THEN ; itab3d_1 = is_tile(tab3d_1)  ; ELSE ; itab3d_1 = 0 ; ENDIF
58      IF( PRESENT(tab4d_1)  ) THEN ; itab4d_1 = is_tile(tab4d_1)  ; ELSE ; itab4d_1 = 0 ; ENDIF
59      IF( PRESENT(tab2d_2)  ) THEN ; itab2d_2 = is_tile(tab2d_2)  ; ELSE ; itab2d_2 = 0 ; ENDIF
60      IF( PRESENT(tab3d_2)  ) THEN ; itab3d_2 = is_tile(tab3d_2)  ; ELSE ; itab3d_2 = 0 ; ENDIF
61
62      CALL prt_ctl_t (tab2d_1, itab2d_1, tab3d_1, itab3d_1, tab4d_1, itab4d_1, tab2d_2, itab2d_2, tab3d_2, itab3d_2,  &
63      &               mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim )
64   END SUBROUTINE prt_ctl
65
66
67   SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2,  &
68      &                  mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim )
69      !!----------------------------------------------------------------------
70      !!                     ***  ROUTINE prt_ctl  ***
71      !!
72      !! ** Purpose : - print sum control of 2D or 3D arrays over the same area
73      !!                in mono and mpp case. This way can be usefull when
74      !!                debugging a new parametrization in mono or mpp.
75      !!
76      !! ** Method  : 2 possibilities exist when setting the sn_cfctl%prtctl parameter to
77      !!                .true. in the ocean namelist:
78      !!              - to debug a MPI run .vs. a mono-processor one;
79      !!                the control print will be done over each sub-domain.
80      !!                The nictl[se] and njctl[se] parameters in the namelist must
81      !!                be set to zero and [ij]splt to the corresponding splitted
82      !!                domain in MPI along respectively i-, j- directions.
83      !!              - to debug a mono-processor run over the whole domain/a specific area;
84      !!                in the first case the nictl[se] and njctl[se] parameters must be set
85      !!                to zero else to the indices of the area to be controled. In both cases
86      !!                isplt and jsplt must be set to 1.
87      !!              - All arguments of the above calling sequence are optional so their
88      !!                name must be explicitly typed if used. For instance if the 3D
89      !!                array tn(:,:,:) must be passed through the prt_ctl subroutine,
90      !!                it must look like: CALL prt_ctl(tab3d_1=tn).
91      !!
92      !!                    tab2d_1 : first 2D array
93      !!                    tab3d_1 : first 3D array
94      !!                    tab4d_1 : first 4D array
95      !!                    mask1   : mask (3D) to apply to the tab[23]d_1 array
96      !!                    clinfo1 : information about the tab[23]d_1 array
97      !!                    tab2d_2 : second 2D array
98      !!                    tab3d_2 : second 3D array
99      !!                    mask2   : mask (3D) to apply to the tab[23]d_2 array
100      !!                    clinfo2 : information about the tab[23]d_2 array
101      !!                    kdim    : k- direction for 3D arrays
102      !!                    clinfo3 : additional information
103      !!----------------------------------------------------------------------
104      INTEGER                             , INTENT(in)           ::   ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2
105      REAL(wp),         DIMENSION(A2D_T(ktab2d_1))    , INTENT(in), OPTIONAL ::   tab2d_1
106      REAL(wp),         DIMENSION(A2D_T(ktab3d_1),:)  , INTENT(in), OPTIONAL ::   tab3d_1
107      REAL(wp),         DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL ::   tab4d_1
108      REAL(wp),         DIMENSION(A2D_T(ktab2d_2))    , INTENT(in), OPTIONAL ::   tab2d_2
109      REAL(wp),         DIMENSION(A2D_T(ktab3d_2),:)  , INTENT(in), OPTIONAL ::   tab3d_2
110      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask1
111      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask2
112      CHARACTER(len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array
113      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo1
114      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo2
115      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo3
116      INTEGER                             , INTENT(in), OPTIONAL ::   kdim
117      !
118      CHARACTER(len=30) :: cl1, cl2
119      INTEGER ::  jn, jl, kdir
120      INTEGER ::  iis, iie, jjs, jje
121      INTEGER ::  itra, inum
122      REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
123      !!----------------------------------------------------------------------
124      !
125      ! Arrays, scalars initialization
126      cl1  = ''
127      cl2  = ''
128      kdir = jpkm1
129      itra = 1
130
131      ! Control of optional arguments
132      IF( PRESENT(clinfo1) )   cl1  = clinfo1
133      IF( PRESENT(clinfo2) )   cl2  = clinfo2
134      IF( PRESENT(kdim)    )   kdir = kdim
135      IF( PRESENT(tab4d_1) )   itra = SIZE(tab4d_1,dim=4)
136
137      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
138      DO jl = 1, SIZE(nall_ictls)
139
140         ! define shoter names...
141         iis = MAX( nall_ictls(jl), ntsi )
142         iie = MIN( nall_ictle(jl), ntei )
143         jjs = MAX( nall_jctls(jl), ntsj )
144         jje = MIN( nall_jctle(jl), ntej )
145
146         IF( PRESENT(clinfo) ) THEN   ;   inum = numprt_top(jl)
147         ELSE                         ;   inum = numprt_oce(jl)
148         ENDIF
149
150         ! Compute the sum control only where the tile domain and control print area overlap
151         IF( iie >= iis .AND. jje >= jjs ) THEN
152            DO jn = 1, itra
153
154               IF( PRESENT(clinfo3) ) THEN
155                  IF    ( clinfo3 == 'tra-ta' )   THEN
156                     zvctl1 = t_ctl(jl)
157                  ELSEIF( clinfo3 == 'tra'    )   THEN
158                     zvctl1 = t_ctl(jl)
159                     zvctl2 = s_ctl(jl)
160                  ELSEIF( clinfo3 == 'dyn'    )   THEN
161                     zvctl1 = u_ctl(jl)
162                     zvctl2 = v_ctl(jl)
163                  ELSE
164                     zvctl1 = tra_ctl(jn,jl)
165                  ENDIF
166               ENDIF
167
168               ! 2D arrays
169               IF( PRESENT(tab2d_1) ) THEN
170                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
171                  ELSE                        ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje)                            )
172                  ENDIF
173               ENDIF
174               IF( PRESENT(tab2d_2) ) THEN
175                  IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
176                  ELSE                        ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje)                            )
177                  ENDIF
178               ENDIF
179
180               ! 3D arrays
181               IF( PRESENT(tab3d_1) ) THEN
182                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
183                  ELSE                        ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir)                                 )
184                  ENDIF
185               ENDIF
186               IF( PRESENT(tab3d_2) ) THEN
187                  IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
188                  ELSE                        ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir)                                 )
189                  ENDIF
190               ENDIF
191
192               ! 4D arrays
193               IF( PRESENT(tab4d_1) ) THEN
194                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
195                  ELSE                        ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn)                                 )
196                  ENDIF
197               ENDIF
198
199               ! Print the result
200               IF( PRESENT(clinfo ) )   cl1  = clinfo(jn)
201               IF( PRESENT(clinfo3) )   THEN
202                  !
203                  IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
204                     WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2
205                  ELSE
206                     WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1 - zvctl1
207                  ENDIF
208                  !
209                  SELECT CASE( clinfo3 )
210                  CASE ( 'tra-ta' )
211                     t_ctl(jl) = zsum1
212                  CASE ( 'tra' )
213                     t_ctl(jl) = zsum1
214                     s_ctl(jl) = zsum2
215                  CASE ( 'dyn' )
216                     u_ctl(jl) = zsum1
217                     v_ctl(jl) = zsum2
218                  CASE default
219                     tra_ctl(jn,jl) = zsum1
220                  END SELECT
221               ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN
222                  WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2
223               ELSE
224                  WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1
225               ENDIF
226
227            END DO
228         ENDIF
229      END DO
230      !
231   END SUBROUTINE prt_ctl_t
232
233
234   SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp )
235      !!----------------------------------------------------------------------
236      !!                     ***  ROUTINE prt_ctl_info  ***
237      !!
238      !! ** Purpose : - print information without any computation
239      !!
240      !! ** Action  : - input arguments
241      !!                    clinfo : information about the ivar
242      !!                    ivar   : value to print
243      !!----------------------------------------------------------------------
244      CHARACTER(len=*),           INTENT(in) ::   clinfo
245      INTEGER         , OPTIONAL, INTENT(in) ::   ivar
246      CHARACTER(len=3), OPTIONAL, INTENT(in) ::   cdcomp   ! only 'top' is accepted
247      !
248      CHARACTER(len=3) :: clcomp
249      INTEGER ::  jl, inum
250      !!----------------------------------------------------------------------
251      !
252      IF( PRESENT(cdcomp) ) THEN   ;   clcomp = cdcomp
253      ELSE                         ;   clcomp = 'oce'
254      ENDIF
255      !
256      DO jl = 1, SIZE(nall_ictls)
257         !
258         IF( clcomp == 'oce' )   inum = numprt_oce(jl)
259         IF( clcomp == 'top' )   inum = numprt_top(jl)
260         !
261         IF ( PRESENT(ivar) ) THEN   ;   WRITE(inum,*) clinfo, ivar
262         ELSE                        ;   WRITE(inum,*) clinfo
263         ENDIF
264         !
265      END DO
266      !
267   END SUBROUTINE prt_ctl_info
268
269
270   SUBROUTINE prt_ctl_init( cdcomp, kntra )
271      !!----------------------------------------------------------------------
272      !!                     ***  ROUTINE prt_ctl_init  ***
273      !!
274      !! ** Purpose :   open ASCII files & compute indices
275      !!----------------------------------------------------------------------
276      CHARACTER(len=3), OPTIONAL, INTENT(in   ) ::   cdcomp   ! only 'top' is accepted
277      INTEGER         , OPTIONAL, INTENT(in   ) ::   kntra    ! only for 'top': number of tracers
278      !
279      INTEGER ::   ji, jj, jl
280      INTEGER ::   inum, idg, idg2
281      INTEGER ::   ijsplt, iimax, ijmax
282      INTEGER, DIMENSION(:,:), ALLOCATABLE ::    iimppt, ijmppt, ijpi, ijpj, iproc
283      INTEGER, DIMENSION(  :), ALLOCATABLE ::     iipos,  ijpos
284      LOGICAL, DIMENSION(:,:), ALLOCATABLE ::   llisoce
285      CHARACTER(len=64) :: clfile_out
286      CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4
287      CHARACTER(len=32) :: clname, cl_run
288      CHARACTER(len= 3) :: clcomp
289      !!----------------------------------------------------------------------
290      !
291      clname = 'output'
292      IF( PRESENT(cdcomp) ) THEN
293         clname = TRIM(clname)//'.'//TRIM(cdcomp)
294         clcomp = cdcomp
295      ELSE
296         clcomp = 'oce'
297      ENDIF
298      !
299      IF( jpnij > 1 ) THEN   ! MULTI processor run
300         cl_run = 'MULTI processor run'
301         idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 )    ! how many digits to we need to write? min=4, max=9
302         WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg        ! '(a,ix.x)'
303         WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1
304         ijsplt = 1
305      ELSE                   ! MONO processor run
306         cl_run = 'MONO processor run '
307         IF(lwp) THEN                  ! control print
308            WRITE(numout,*)
309            WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters'
310            WRITE(numout,*) '~~~~~~~~~~~~~'
311         ENDIF
312         IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 )   THEN    ! print control done over the default area
313            nn_isplt = MAX(1, nn_isplt)            ! number of processors following i-direction
314            nn_jsplt = MAX(1, nn_jsplt)            ! number of processors following j-direction
315            ijsplt = nn_isplt * nn_jsplt           ! total number of processors ijsplt
316            IF( ijsplt == 1 )   CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' )
317            IF(lwp) WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
318            IF(lwp) WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
319            idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 )    ! how many digits to we need to write? min=4, max=9
320            WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg         ! '(a,ix.x)'
321            IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0
322         ELSE                                             ! print control done over a specific  area
323            ijsplt = 1
324            IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo )   THEN
325               CALL ctl_warn( '          - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' )
326               nn_ictls = 1
327            ENDIF
328            IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo )   THEN
329               CALL ctl_warn( '          - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' )
330               nn_ictle = Ni0glo
331            ENDIF
332            IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo )   THEN
333               CALL ctl_warn( '          - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' )
334               nn_jctls = 1
335            ENDIF
336            IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo )   THEN
337               CALL ctl_warn( '          - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' )
338               nn_jctle = Nj0glo
339            ENDIF
340            WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
341            WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
342            WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
343            WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
344            idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) )   ! temporary use of idg to store the largest index
345            idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 )                ! how many digits to we need to write? min=4, max=9
346            WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg         ! '(4(a,ix.x))'
347            WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle
348         ENDIF
349      ENDIF
350
351      ! Allocate arrays
352      IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) )
353
354      IF( jpnij > 1 ) THEN   ! MULTI processor run
355         !
356         nall_ictls(1) = Nis0
357         nall_ictle(1) = Nie0
358         nall_jctls(1) = Njs0
359         nall_jctle(1) = Nje0
360         !
361      ELSE                   ! MONO processor run
362         !
363         IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 )   THEN    ! print control done over the default area
364            !
365            ALLOCATE(  iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt),  ijpi(nn_isplt,nn_jsplt),  ijpj(nn_isplt,nn_jsplt),   &
366               &      llisoce(nn_isplt,nn_jsplt),  iproc(nn_isplt,nn_jsplt), iipos(nn_isplt*nn_jsplt), ijpos(nn_isplt*nn_jsplt) )
367            CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj )
368            CALL mpp_is_ocean( llisoce )
369            CALL mpp_getnum( llisoce, iproc, iipos, ijpos )
370            !
371            DO jj = 1,nn_jsplt
372               DO ji = 1, nn_isplt
373                  jl = iproc(ji,jj) + 1
374                  nall_ictls(jl) = iimppt(ji,jj) - 1 +      1      + nn_hls
375                  nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls
376                  nall_jctls(jl) = ijmppt(ji,jj) - 1 +      1      + nn_hls
377                  nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls
378               END DO
379            END DO
380            !
381            DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos )
382            !
383         ELSE                                             ! print control done over a specific  area
384            !
385            nall_ictls(1) = nn_ictls + nn_hls
386            nall_ictle(1) = nn_ictle + nn_hls
387            nall_jctls(1) = nn_jctls + nn_hls
388            nall_jctle(1) = nn_jctle + nn_hls
389            !
390         ENDIF
391      ENDIF
392
393      ! Initialization
394      IF( clcomp == 'oce' ) THEN
395         ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) )
396         t_ctl(:) = 0.e0
397         s_ctl(:) = 0.e0
398         u_ctl(:) = 0.e0
399         v_ctl(:) = 0.e0
400      ENDIF
401      IF( clcomp == 'top' ) THEN
402         ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) )
403         tra_ctl(:,:) = 0.e0
404      ENDIF
405
406      DO jl = 1,ijsplt
407
408         IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1
409
410         CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
411         IF( clcomp == 'oce' )   numprt_oce(jl) = inum
412         IF( clcomp == 'top' )   numprt_top(jl) = inum
413         WRITE(inum,*)
414         WRITE(inum,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC'
415         WRITE(inum,*) '                       NEMO team'
416         WRITE(inum,*) '            Ocean General Circulation Model'
417         IF( clcomp == 'oce' )   WRITE(inum,*) '                NEMO version 4.x  (2020) '
418         IF( clcomp == 'top' )   WRITE(inum,*) '                 TOP vversion x (2020) '
419         WRITE(inum,*)
420         IF( ijsplt > 1 )   &
421            &   WRITE(inum,*) '              MPI-subdomain number: ', jl-1
422         IF(  jpnij > 1 )   &
423            &   WRITE(inum,*) '              MPI-subdomain number: ', narea-1
424         WRITE(inum,*)
425         WRITE(inum,'(19x,a20)') cl_run
426         WRITE(inum,*)
427         WRITE(inum,*) 'prt_ctl :  Sum control indices'
428         WRITE(inum,*) '~~~~~~~'
429         WRITE(inum,*)
430         !
431         ! clfmt2: '              ----- jctle = XXX (YYY) -----'             -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)'
432         ! clfmt3: '              |                           |'             -> '(18x, a1, Nx, a1)'
433         ! clfmt4: '        ictls = XXX (YYY)           ictle = XXX (YYY)'   -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)'
434         !         '              |                           |'
435         !         '              ----- jctle = XXX (YYY) -----'
436         ! clfmt5: '   njmpp = XXX'                                          -> '(Nx, a9, iM)'
437         ! clfmt6: '           nimpp = XXX'                                  -> '(Nx, a9, iM)'
438         !
439         idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) )   ! temporary use of idg
440         idg = INT(LOG10(REAL(idg,wp))) + 1                                                     ! how many digits do we use?
441         idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) )
442         idg2 = INT(LOG10(REAL(idg2,wp))) + 1                                                   ! how many digits do we use?
443         WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2
444         WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2
445         WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") &
446            &          18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2
447         WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13)
448         WRITE(inum,clfmt3) '|', '|'
449         WRITE(inum,clfmt3) '|', '|'
450         WRITE(inum,clfmt3) '|', '|'
451         WRITE(inum,clfmt4)                 ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ',   &
452            &                               ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') '
453         WRITE(inum,clfmt3) '|', '|'
454         WRITE(inum,clfmt3) '|', '|'
455         WRITE(inum,clfmt3) '|', '|'
456         WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13)
457         WRITE(inum,*)
458         WRITE(inum,*)
459         !
460      END DO
461      !
462   END SUBROUTINE prt_ctl_init
463
464
465   !!======================================================================
466END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.