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/branches/2020/r12377_ticket2386/src/OCE/IOM – NEMO

source: NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/prtctl.F90 @ 13540

Last change on this file since 13540 was 13540, checked in by andmirek, 3 years ago

Ticket #2386: update to latest trunk

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