Changeset 12840


Ignore:
Timestamp:
2020-05-01T10:58:58+02:00 (7 months ago)
Author:
smasson
Message:

r12581_ticket2418: improve stpctl error messages and release the max of 9999 MPI tasks in files names, see #2418

Location:
NEMO/branches/2020/r12581_ticket2418
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/ICB/icbrst.F90

    r12472 r12840  
    188188      ! 
    189189      INTEGER ::   jn   ! dummy loop index 
     190      INTEGER ::   idg  ! number of digits 
    190191      INTEGER ::   ix_dim, iy_dim, ik_dim, in_dim 
    191192      CHARACTER(len=256)     :: cl_path 
    192193      CHARACTER(len=256)     :: cl_filename 
    193194      CHARACTER(len=256)     :: cl_kt 
     195      CHARACTER(LEN=12 )     :: clfmt            ! writing format 
    194196      TYPE(iceberg), POINTER :: this 
    195197      TYPE(point)  , POINTER :: pt 
     
    213215         cl_filename = TRIM(cexper)//"_"//TRIM(ADJUSTL(cl_kt))//"_"//TRIM(cn_icbrst_out) 
    214216         IF( lk_mpp ) THEN 
    215             WRITE(cl_filename,'(A,"_",I4.4,".nc")') TRIM(cl_filename), narea-1 
     217            idg = MAX( INT(LOG10(REAL(jpnij-1,wp))) + 1, 4 )          ! how many digits to we need to write? min=4, max=9 
     218            WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
     219            WRITE(cl_filename,clfmt) TRIM(cl_filename), '_', narea-1, '.nc' 
    216220         ELSE 
    217221            WRITE(cl_filename,'(A,".nc")') TRIM(cl_filename) 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/ICB/icbtrj.F90

    r12489 r12840  
    6262      ! 
    6363      INTEGER                ::   iret, iyear, imonth, iday 
     64      INTEGER                ::   idg  ! number of digits 
    6465      REAL(wp)               ::   zfjulday, zsec 
    6566      CHARACTER(len=80)      ::   cl_filename 
     67      CHARACTER(LEN=12)      ::   clfmt            ! writing format 
    6668      CHARACTER(LEN=20)      ::   cldate_ini, cldate_end 
    6769      TYPE(iceberg), POINTER ::   this 
     
    8082 
    8183      ! define trajectory output name 
    82       IF ( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A,"_",I4.4,".nc")')   & 
    83          &                        TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)), narea-1 
    84       ELSE                 ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A         ,".nc")')   & 
    85          &                        TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)) 
     84      cl_filename = 'trajectory_icebergs_'//TRIM(ADJUSTL(cldate_ini))//'-'//TRIM(ADJUSTL(cldate_end)) 
     85      IF ( lk_mpp ) THEN 
     86         idg = MAX( INT(LOG10(REAL(jpnij-1,wp))) + 1, 4 )          ! how many digits to we need to write? min=4, max=9 
     87         WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
     88         WRITE(cl_filename,clfmt) TRIM(cl_filename), '_', narea-1, '.nc' 
     89      ELSE 
     90         WRITE(cl_filename,'(A,".nc")') TRIM(cl_filename) 
    8691      ENDIF 
    8792      IF( lwp .AND. nn_verbose_level >= 0 )   WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/IOM/iom_nf90.F90

    r12655 r12840  
    6262      CHARACTER(LEN=256) ::   clinfo           ! info character 
    6363      CHARACTER(LEN=256) ::   cltmp            ! temporary character 
     64      CHARACTER(LEN=12 ) ::   clfmt            ! writing format 
    6465      CHARACTER(LEN=3  ) ::   clcomp           ! name of component calling iom_nf90_open 
     66      INTEGER            ::   idg              ! number of digits 
    6567      INTEGER            ::   iln              ! lengths of character 
    6668      INTEGER            ::   istop            ! temporary storage of nstop 
     
    109111         IF( ldwrt ) THEN              !* the file should be open in write mode so we create it... 
    110112            IF( jpnij > 1 ) THEN 
    111                WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea-1, '.nc' 
     113               idg = MAX( INT(LOG10(REAL(jpnij-1,wp))) + 1, 4 )          ! how many digits to we need to write? min=4, max=9 
     114               WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
     115               WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc' 
    112116               cdname = TRIM(cltmp) 
    113117            ENDIF 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/LBC/lib_mpp.F90

    r12684 r12840  
    11121112      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
    11131113      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
     1114      ! 
     1115      CHARACTER(LEN=8) ::   clfmt            ! writing format 
     1116      INTEGER ::   inum 
     1117      INTEGER ::   idg  ! number of digits 
    11141118      !!---------------------------------------------------------------------- 
    11151119      ! 
    11161120      nstop = nstop + 1 
    11171121      ! 
    1118       ! force to open ocean.output file if not already opened 
    1119       IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     1122      IF( numout == 6 ) THEN                          ! force to open ocean.output file if not already opened 
     1123         CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     1124      ELSE 
     1125         IF( narea > 1 .AND. cd1 == 'STOP' ) THEN     ! add an error message in ocean.output 
     1126            CALL ctl_opn( inum,'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
     1127            WRITE(inum,*) 
     1128            idg = MAX( INT(LOG10(REAL(jpnij-1,wp))) + 1, 4 )        ! how many digits to we need to write? min=4, max=9 
     1129            WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg     ! '(a,ix.x)' 
     1130            WRITE(inum,clfmt) ' ===>>> : see E R R O R in ocean.output_', narea - 1 
     1131         ENDIF 
     1132      ENDIF 
    11201133      ! 
    11211134                            WRITE(numout,*) 
     
    12091222      ! 
    12101223      CHARACTER(len=80) ::   clfile 
     1224      CHARACTER(LEN=10) ::   clfmt            ! writing format 
    12111225      INTEGER           ::   iost 
     1226      INTEGER           ::   idg  ! number of digits 
    12121227      !!---------------------------------------------------------------------- 
    12131228      ! 
     
    12161231      clfile = TRIM(cdfile) 
    12171232      IF( PRESENT( karea ) ) THEN 
    1218          IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1 
     1233         IF( karea > 1 ) THEN 
     1234            idg = MAX( INT(LOG10(REAL(jpnij-1,wp))) + 1, 4 )        ! how many digits to we need to write? min=4, max=9 
     1235            WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg   ! '(a,a,ix.x)' 
     1236            WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 
     1237         ENDIF 
    12191238      ENDIF 
    12201239#if defined key_agrif 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/OBS/obs_grid.F90

    r10068 r12840  
    684684         & fhistx1, fhistx2, fhisty1, fhisty2 
    685685      REAL(wp) :: histtol 
    686        
     686      CHARACTER(LEN=26) :: clfmt            ! writing format 
     687      INTEGER           :: idg              ! number of digits 
     688  
    687689      IF (ln_grid_search_lookup) THEN 
    688690          
     
    709711 
    710712         IF ( ln_grid_global ) THEN 
    711             WRITE(cfname, FMT="(A,'_',A)") & 
    712                &          TRIM(cn_gridsearchfile), 'global.nc' 
     713            WRITE(cfname, FMT="(A,'_',A)") TRIM(cn_gridsearchfile), 'global.nc' 
    713714         ELSE 
    714             WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") & 
    715                &          TRIM(cn_gridsearchfile), nproc, jpni, jpnj 
     715            idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )        ! how many digits to we need to write? min=4, max=9 
     716            ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)" 
     717            WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg 
     718            WRITE(cfname,      clfmt     ) TRIM(cn_gridsearchfile),'_', nproc,'of', jpni,'by', jpnj,'.nc' 
    716719         ENDIF 
    717720 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/OBS/obs_write.F90

    r12377 r12840  
    8686      CHARACTER(LEN=40) :: clfname 
    8787      CHARACTER(LEN=10) :: clfiletype 
     88      CHARACTER(LEN=12) :: clfmt            ! writing format 
     89      INTEGER :: idg                        ! number of digits 
    8890      INTEGER :: ilevel 
    8991      INTEGER :: jvar 
     
    181183      fbdata%caddname(1)   = 'Hx' 
    182184 
    183       WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
     185      idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )            ! how many digits to we need to write? min=4, max=9 
     186      WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
     187      WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc' 
    184188 
    185189      IF(lwp) THEN 
     
    326330      CHARACTER(LEN=10) :: clfiletype 
    327331      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 
     332      CHARACTER(LEN=12) :: clfmt           ! writing format 
     333      INTEGER :: idg                       ! number of digits 
    328334      INTEGER :: jo 
    329335      INTEGER :: ja 
     
    453459      fbdata%caddname(1)   = 'Hx' 
    454460 
    455       WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
     461      idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )            ! how many digits to we need to write? min=4, max=9 
     462      WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
     463      WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc' 
    456464 
    457465      IF(lwp) THEN 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/STO/stopar.F90

    r12377 r12840  
    684684      !! ** Purpose :   read stochastic parameters from restart file 
    685685      !!---------------------------------------------------------------------- 
    686       INTEGER  :: jsto, jseed 
     686      INTEGER             ::   jsto, jseed 
     687      INTEGER             ::   idg                 ! number of digits 
    687688      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    688689      REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
    689690      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name 
    690691      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name 
    691       CHARACTER(LEN=10)   ::   clseed='seed0_0000' ! seed variable name 
     692      CHARACTER(LEN=15)   ::   clseed='seed0_0000' ! seed variable name 
     693      CHARACTER(LEN=6)    ::   clfmt               ! writing format 
    692694      !!---------------------------------------------------------------------- 
    693695 
     
    717719         IF (ln_rstseed) THEN 
    718720            ! Get saved state of the random number generator 
     721            idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )        ! how many digits to we need to write? min=4, max=9 
     722            WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg     ! "(ix.x)" 
    719723            DO jseed = 1 , 4 
    720                WRITE(clseed(5:5) ,'(i1.1)') jseed 
    721                WRITE(clseed(7:10),'(i4.4)') narea 
    722                CALL iom_get( numstor, clseed , zrseed(jseed) ) 
     724               WRITE(clseed(5:5)      ,'(i1.1)') jseed 
     725               WRITE(clseed(7:7+idg-1),  clfmt ) narea 
     726               CALL iom_get( numstor, clseed(1:7+idg-1) , zrseed(jseed) ) 
    723727            END DO 
    724728            ziseed = TRANSFER( zrseed , ziseed) 
     
    742746      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
    743747      !! 
    744       INTEGER  :: jsto, jseed 
     748      INTEGER             ::   jsto, jseed 
     749      INTEGER             ::   idg                 ! number of digits 
    745750      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    746751      REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
     
    749754      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name 
    750755      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name 
    751       CHARACTER(LEN=10)   ::   clseed='seed0_0000' ! seed variable name 
     756      CHARACTER(LEN=15)   ::   clseed='seed0_0000' ! seed variable name 
     757      CHARACTER(LEN=6)    ::   clfmt               ! writing format 
    752758      !!---------------------------------------------------------------------- 
    753759 
     
    771777            CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) 
    772778            zrseed = TRANSFER( ziseed , zrseed) 
     779            idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )        ! how many digits to we need to write? min=4, max=9 
     780            WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg     ! "(ix.x)" 
    773781            DO jseed = 1 , 4 
    774                WRITE(clseed(5:5) ,'(i1.1)') jseed 
    775                WRITE(clseed(7:10),'(i4.4)') narea 
    776                CALL iom_rstput( kt, nitrst, numstow, clseed , zrseed(jseed) ) 
     782               WRITE(clseed(5:5)      ,'(i1.1)') jseed 
     783               WRITE(clseed(7:7+idg-1),  clfmt ) narea 
     784               CALL iom_rstput( kt, nitrst, numstow, clseed(1:7+idg-1), zrseed(jseed) ) 
    777785            END DO 
    778786            ! 2D stochastic parameters 
  • NEMO/branches/2020/r12581_ticket2418/src/OCE/stpctl.F90

    r12685 r12840  
    6464      INTEGER                         ::   ji                                    ! dummy loop indices 
    6565      INTEGER                         ::   idtime, istatus 
    66       INTEGER, DIMENSION(3,4)         ::   iloc                                  ! min/max loc indices 
     66      INTEGER , DIMENSION(9)          ::   iareasum, iareamin, iareamax 
     67      INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
    6768      REAL(wp)                        ::   zzz                                   ! local real  
    68       REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal, zarea 
     69      REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal 
    6970      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
    7071      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
     
    176177         &  ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN   ! NaN encounter in the tests 
    177178         ! 
     179         iloc(:,:) = 0 
    178180         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
    179181            ! first: close the netcdf file, so we can read it 
     
    185187            CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,4) ) 
    186188            ! find which subdomain has the max. 
    187             zarea(:) = 0._wp 
     189            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    188190            DO ji = 1, 9 
    189                IF( zmaxlocal(ji) == zmax(ji) )   zarea(ji) = narea  
     191               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     192                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     193               ENDIF 
    190194            END DO 
    191             CALL mpp_max( "stpctl", zarea )         ! max over the global domain 
     195            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     196            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     197            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
    192198         ELSE                    ! find local min and max locations: 
    193199            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
     
    196202            iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    197203            iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    198             zarea(:) = narea     ! this is local information 
     204            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    199205         ENDIF 
    200206         ! 
    201207         WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
    202          WRITE(ctmp2,9100) kt, ' |ssh| max ',  zmax(1), iloc(1,1), iloc(2,1),            NINT(zarea(1))-1 
    203          WRITE(ctmp3,9200) kt, ' |U|   max ',  zmax(2), iloc(1,2), iloc(2,2), iloc(3,2), NINT(zarea(2))-1 
    204          WRITE(ctmp4,9200) kt, ' Sal   min ', -zmax(3), iloc(1,3), iloc(2,3), iloc(3,3), NINT(zarea(3))-1 
    205          WRITE(ctmp5,9200) kt, ' Sal   max ',  zmax(4), iloc(1,4), iloc(2,4), iloc(3,4), NINT(zarea(4))-1 
     208         CALL wrt_line( ctmp2, kt, '|ssh| max',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     209         CALL wrt_line( ctmp3, kt, '|U|   max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     210         CALL wrt_line( ctmp4, kt, 'Sal   min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
     211         CALL wrt_line( ctmp5, kt, 'Sal   max',  zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 
    206212         IF( Agrif_Root() ) THEN 
    207213            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
     
    214220         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    215221            IF(lwp)   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    216          ELSE   ! only mpi subdomains with errors are here -> STOP now 
     222         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
    217223            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    218224         ENDIF 
     
    223229      ENDIF 
    224230      ! 
    225 9100  FORMAT(' kt ',i8,a,1pg11.4,' at i j  ',2i6, 6x,' MPI rank',i6) 
    226 9200  FORMAT(' kt ',i8,a,1pg11.4,' at i j k',2i6, i6,' MPI rank',i6) 
    2272319500  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 
    228232      ! 
    229233   END SUBROUTINE stp_ctl 
     234 
     235 
     236   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
     237      !!---------------------------------------------------------------------- 
     238      !!                     ***  ROUTINE wrt_line  *** 
     239      !! 
     240      !! ** Purpose :   write information line 
     241      !! 
     242      !!---------------------------------------------------------------------- 
     243      CHARACTER(len=*),      INTENT(  out) ::   cdline 
     244      CHARACTER(len=*),      INTENT(in   ) ::   cdprefix 
     245      REAL(wp),              INTENT(in   ) ::   pval 
     246      INTEGER, DIMENSION(3), INTENT(in   ) ::   kloc 
     247      INTEGER,               INTENT(in   ) ::   kt, ksum, kmin, kmax 
     248      ! 
     249      CHARACTER(len=9) ::   clkt, clsum, clmin, clmax 
     250      CHARACTER(len=9) ::   cli, clj, clk 
     251      CHARACTER(len=1) ::   clfmt 
     252      CHARACTER(len=4) ::   cl4   ! needed to be able to compile with Agrif, I don't know why 
     253      INTEGER          ::   ifmtk 
     254      !!---------------------------------------------------------------------- 
     255      WRITE(clkt , '(i9)') kt 
     256       
     257      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij  ,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     258      !!! WRITE(clsum, '(i'//clfmt//')') ksum                   ! this is creating a compilation error with AGRIF 
     259      cl4 = '(i'//clfmt//')'   ;   WRITE(clsum, cl4) ksum 
     260      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij-1,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     261      cl4 = '(i'//clfmt//')'   ;   WRITE(clmin, cl4) kmin-1 
     262                                   WRITE(clmax, cl4) kmax-1 
     263      ! 
     264      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1      ! how many digits to we need to write jpiglo? (we decide max = 9) 
     265      cl4 = '(i'//clfmt//')'   ;   WRITE(cli, cl4) kloc(1)      ! this is ok with AGRIF 
     266      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1      ! how many digits to we need to write jpjglo? (we decide max = 9) 
     267      cl4 = '(i'//clfmt//')'   ;   WRITE(clj, cl4) kloc(2)      ! this is ok with AGRIF 
     268      ! 
     269      IF( ksum == 1 ) THEN   ;   WRITE(cdline,9100) TRIM(clmin) 
     270      ELSE                   ;   WRITE(cdline,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) 
     271      ENDIF 
     272      IF(kloc(3) == 0) THEN 
     273         ifmtk = INT(LOG10(REAL(jpk,wp))) + 1                   ! how many digits to we need to write jpk? (we decide max = 9) 
     274         clk = REPEAT(' ', ifmtk)                               ! create the equivalent in blank string 
     275         WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(cdline) 
     276      ELSE 
     277         WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1      ! how many digits to we need to write jpk? (we decide max = 9) 
     278         !!! WRITE(clk, '(i'//clfmt//')') kloc(3)               ! this is creating a compilation error with AGRIF 
     279         cl4 = '(i'//clfmt//')'   ;   WRITE(clk, cl4) kloc(3)   ! this is ok with AGRIF 
     280         WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj),    TRIM(clk), TRIM(cdline) 
     281      ENDIF 
     282      ! 
     2839100  FORMAT('MPI rank ', a) 
     2849200  FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 
     2859300  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j   ', a, ' ', a, ' ', a, ' ', a) 
     2869400  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 
     287      ! 
     288   END SUBROUTINE wrt_line 
     289 
    230290 
    231291   !!====================================================================== 
  • NEMO/branches/2020/r12581_ticket2418/src/SAS/stpctl.F90

    r12685 r12840  
    6363      INTEGER                         ::   ji                                    ! dummy loop indices 
    6464      INTEGER                         ::   idtime, istatus 
    65       INTEGER, DIMENSION(2,3)         ::   iloc                                  ! min/max loc indices 
     65      INTEGER , DIMENSION(4)          ::   iareasum, iareamin, iareamax 
     66      INTEGER , DIMENSION(3,3)        ::   iloc                                  ! min/max loc indices 
    6667      REAL(wp)                        ::   zzz                                   ! local real  
    67       REAL(wp), DIMENSION(4)          ::   zmax, zmaxlocal, zarea 
     68      REAL(wp), DIMENSION(4)          ::   zmax, zmaxlocal 
    6869      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
    6970      LOGICAL, DIMENSION(jpi,jpj)     ::   llmsk 
     
    139140         &  ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN   ! NaN encounter in the tests 
    140141         ! 
     142         iloc(:,:) = 0 
    141143         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
    142144            ! first: close the netcdf file, so we can read it 
     
    147149            CALL mpp_minloc( 'stpctl',      tm_i(:,:) - 273.15_wp, tmask(:,:,1), zzz, iloc(1:2,3) ) 
    148150            ! find which subdomain has the max. 
    149             zarea(:) = 0._wp 
     151            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    150152            DO ji = 1, 4 
    151                IF( zmaxlocal(ji) == zmax(ji) )   zarea(ji) = narea  
     153               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     154                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     155               ENDIF 
    152156            END DO 
    153             CALL mpp_max( "stpctl", zarea )         ! max over the global domain 
     157            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     158            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     159            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
    154160         ELSE                    ! find local min and max locations: 
    155161            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
     
    157163            iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) )          , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    158164            iloc(1:2,3) = MINLOC(       tm_i(:,:) - 273.15_wp, mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    159             zarea(:) = narea     ! this is local information 
     165            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    160166         ENDIF 
    161167         ! 
    162168         WRITE(ctmp1,*) ' stp_ctl: ice_thick > 100 m or |ice_vel| > 10 m/s or ice_temp < -100 degC or NaN encounter in the tests' 
    163          WRITE(ctmp2,9100) kt, ' ice_thick max',  zmax(1), iloc(1,1), iloc(2,1), NINT(zarea(1))-1 
    164          WRITE(ctmp3,9100) kt, ' |ice_vel| max',  zmax(2), iloc(1,2), iloc(2,3), NINT(zarea(2))-1 
    165          WRITE(ctmp4,9100) kt, ' ice_temp  min', -zmax(3), iloc(1,2), iloc(2,3), NINT(zarea(3))-1 
     169         CALL wrt_line( ctmp2, kt, 'ice_thick max',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     170         CALL wrt_line( ctmp3, kt, '|ice_vel| max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     171         CALL wrt_line( ctmp4, kt, 'ice_temp  min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
    166172         IF( Agrif_Root() ) THEN 
    167173            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
     
    174180         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    175181            IF(lwp)   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    176          ELSE   ! only mpi subdomains with errors are here -> STOP now 
     182         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
    177183            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    178184         ENDIF 
     
    183189      ENDIF 
    184190      ! 
    185 9100  FORMAT(' kt ',i8,a,1pg11.4,' at i j',2i6,' MPI rank',i6) 
    1861919500  FORMAT(' it :', i8, '    vt_i_max: ', D23.16, ' |u|_max: ', D23.16,' tm_i_min: ', D23.16) 
    187192      ! 
    188193   END SUBROUTINE stp_ctl 
     194 
     195 
     196   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
     197      !!---------------------------------------------------------------------- 
     198      !!                     ***  ROUTINE wrt_line  *** 
     199      !! 
     200      !! ** Purpose :   write information line 
     201      !! 
     202      !!---------------------------------------------------------------------- 
     203      CHARACTER(len=*),      INTENT(  out) ::   cdline 
     204      CHARACTER(len=*),      INTENT(in   ) ::   cdprefix 
     205      REAL(wp),              INTENT(in   ) ::   pval 
     206      INTEGER, DIMENSION(3), INTENT(in   ) ::   kloc 
     207      INTEGER,               INTENT(in   ) ::   kt, ksum, kmin, kmax 
     208      ! 
     209      CHARACTER(len=9) ::   clkt, clsum, clmin, clmax 
     210      CHARACTER(len=9) ::   cli, clj, clk 
     211      CHARACTER(len=1) ::   clfmt 
     212      CHARACTER(len=4) ::   cl4   ! needed to be able to compile with Agrif, I don't know why 
     213      INTEGER          ::   ifmtk 
     214      !!---------------------------------------------------------------------- 
     215      WRITE(clkt , '(i9)') kt 
     216       
     217      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij  ,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     218      !!! WRITE(clsum, '(i'//clfmt//')') ksum                   ! this is creating a compilation error with AGRIF 
     219      cl4 = '(i'//clfmt//')'   ;   WRITE(clsum, cl4) ksum 
     220      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij-1,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     221      cl4 = '(i'//clfmt//')'   ;   WRITE(clmin, cl4) kmin-1 
     222                                   WRITE(clmax, cl4) kmax-1 
     223      ! 
     224      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1      ! how many digits to we need to write jpiglo? (we decide max = 9) 
     225      cl4 = '(i'//clfmt//')'   ;   WRITE(cli, cl4) kloc(1)      ! this is ok with AGRIF 
     226      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1      ! how many digits to we need to write jpjglo? (we decide max = 9) 
     227      cl4 = '(i'//clfmt//')'   ;   WRITE(clj, cl4) kloc(2)      ! this is ok with AGRIF 
     228      ! 
     229      IF( ksum == 1 ) THEN   ;   WRITE(cdline,9100) TRIM(clmin) 
     230      ELSE                   ;   WRITE(cdline,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) 
     231      ENDIF 
     232      IF(kloc(3) == 0) THEN 
     233         ifmtk = INT(LOG10(REAL(jpk,wp))) + 1                   ! how many digits to we need to write jpk? (we decide max = 9) 
     234         clk = REPEAT(' ', ifmtk)                               ! create the equivalent in blank string 
     235         WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(cdline) 
     236      ELSE 
     237         WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1      ! how many digits to we need to write jpk? (we decide max = 9) 
     238         !!! WRITE(clk, '(i'//clfmt//')') kloc(3)               ! this is creating a compilation error with AGRIF 
     239         cl4 = '(i'//clfmt//')'   ;   WRITE(clk, cl4) kloc(3)   ! this is ok with AGRIF 
     240         WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj),    TRIM(clk), TRIM(cdline) 
     241      ENDIF 
     242      ! 
     2439100  FORMAT('MPI rank ', a) 
     2449200  FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 
     2459300  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j   ', a, ' ', a, ' ', a, ' ', a) 
     2469400  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 
     247      ! 
     248   END SUBROUTINE wrt_line 
     249 
    189250 
    190251   !!====================================================================== 
  • NEMO/branches/2020/r12581_ticket2418/tests/CANAL/MY_SRC/stpctl.F90

    r12685 r12840  
    6464      INTEGER                         ::   ji                                    ! dummy loop indices 
    6565      INTEGER                         ::   idtime, istatus 
    66       INTEGER, DIMENSION(3,4)         ::   iloc                                  ! min/max loc indices 
     66      INTEGER , DIMENSION(9)          ::   iareasum, iareamin, iareamax 
     67      INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
    6768      REAL(wp)                        ::   zzz                                   ! local real  
    68       REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal, zarea 
     69      REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal 
    6970      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
    7071      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
     
    176177         &  ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN   ! NaN encounter in the tests 
    177178         ! 
     179         iloc(:,:) = 0 
    178180         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
    179181            ! first: close the netcdf file, so we can read it 
     
    182184            CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,         Kmm)), ssmask(:,:  ), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
    183185            CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,       Kmm)),  umask(:,:,:), zzz, iloc(1:3,2) ) 
    184             CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,3) ) 
    185             CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,4) ) 
     186!!$            CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,3) ) 
     187!!$            CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,4) ) 
    186188            ! find which subdomain has the max. 
    187             zarea(:) = 0._wp 
     189            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    188190            DO ji = 1, 9 
    189                IF( zmaxlocal(ji) == zmax(ji) )   zarea(ji) = narea  
     191               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     192                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     193               ENDIF 
    190194            END DO 
    191             CALL mpp_max( "stpctl", zarea )         ! max over the global domain 
     195            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     196            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     197            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
    192198         ELSE                    ! find local min and max locations: 
    193199            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    194200            iloc(1:2,1) = MAXLOC( ABS( ssh(:,:,         Kmm)), mask = ssmask(:,:  ) == 1._wp ) + (/ nimpp - 1, njmpp - 1    /) 
    195201            iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask =  umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    196             iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    197             iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    198             zarea(:) = narea     ! this is local information 
    199          ENDIF 
    200          ! 
    201          WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
    202          WRITE(ctmp2,9100) kt, ' |ssh| max ',  zmax(1), iloc(1,1), iloc(2,1),            NINT(zarea(1))-1 
    203          WRITE(ctmp3,9200) kt, ' |U|   max ',  zmax(2), iloc(1,2), iloc(2,2), iloc(3,2), NINT(zarea(2))-1 
    204          WRITE(ctmp4,9200) kt, ' Sal   min ', -zmax(3), iloc(1,3), iloc(2,3), iloc(3,3), NINT(zarea(3))-1 
    205          WRITE(ctmp5,9200) kt, ' Sal   max ',  zmax(4), iloc(1,4), iloc(2,4), iloc(3,4), NINT(zarea(4))-1 
     202!!$            iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
     203!!$            iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
     204            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
     205         ENDIF 
     206         ! 
     207         WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s or  NaN encounter in the tests' 
     208         CALL wrt_line( ctmp2, kt, '|ssh| max',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     209         CALL wrt_line( ctmp3, kt, '|U|   max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     210!!$         CALL wrt_line( ctmp4, kt, 'Sal   min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
     211!!$         CALL wrt_line( ctmp5, kt, 'Sal   max',  zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 
    206212         IF( Agrif_Root() ) THEN 
    207213            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
     
    213219         ! 
    214220         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    215             IF(lwp)   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    216          ELSE   ! only mpi subdomains with errors are here -> STOP now 
    217             CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
     221            IF(lwp)   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
     222         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
     223            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
    218224         ENDIF 
    219225         ! 
     
    223229      ENDIF 
    224230      ! 
    225 9100  FORMAT(' kt ',i8,a,1pg11.4,' at i j  ',2i6, 6x,' MPI rank',i6) 
    226 9200  FORMAT(' kt ',i8,a,1pg11.4,' at i j k',2i6, i6,' MPI rank',i6) 
    2272319500  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 
    228232      ! 
    229233   END SUBROUTINE stp_ctl 
     234 
     235 
     236   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
     237      !!---------------------------------------------------------------------- 
     238      !!                     ***  ROUTINE wrt_line  *** 
     239      !! 
     240      !! ** Purpose :   write information line 
     241      !! 
     242      !!---------------------------------------------------------------------- 
     243      CHARACTER(len=*),      INTENT(  out) ::   cdline 
     244      CHARACTER(len=*),      INTENT(in   ) ::   cdprefix 
     245      REAL(wp),              INTENT(in   ) ::   pval 
     246      INTEGER, DIMENSION(3), INTENT(in   ) ::   kloc 
     247      INTEGER,               INTENT(in   ) ::   kt, ksum, kmin, kmax 
     248      ! 
     249      CHARACTER(len=9) ::   clkt, clsum, clmin, clmax 
     250      CHARACTER(len=9) ::   cli, clj, clk 
     251      CHARACTER(len=1) ::   clfmt 
     252      CHARACTER(len=4) ::   cl4   ! needed to be able to compile with Agrif, I don't know why 
     253      INTEGER          ::   ifmtk 
     254      !!---------------------------------------------------------------------- 
     255      WRITE(clkt , '(i9)') kt 
     256       
     257      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij  ,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     258      !!! WRITE(clsum, '(i'//clfmt//')') ksum                   ! this is creating a compilation error with AGRIF 
     259      cl4 = '(i'//clfmt//')'   ;   WRITE(clsum, cl4) ksum 
     260      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij-1,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     261      cl4 = '(i'//clfmt//')'   ;   WRITE(clmin, cl4) kmin-1 
     262                                   WRITE(clmax, cl4) kmax-1 
     263      ! 
     264      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1      ! how many digits to we need to write jpiglo? (we decide max = 9) 
     265      cl4 = '(i'//clfmt//')'   ;   WRITE(cli, cl4) kloc(1)      ! this is ok with AGRIF 
     266      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1      ! how many digits to we need to write jpjglo? (we decide max = 9) 
     267      cl4 = '(i'//clfmt//')'   ;   WRITE(clj, cl4) kloc(2)      ! this is ok with AGRIF 
     268      ! 
     269      IF( ksum == 1 ) THEN   ;   WRITE(cdline,9100) TRIM(clmin) 
     270      ELSE                   ;   WRITE(cdline,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) 
     271      ENDIF 
     272      IF(kloc(3) == 0) THEN 
     273         ifmtk = INT(LOG10(REAL(jpk,wp))) + 1                   ! how many digits to we need to write jpk? (we decide max = 9) 
     274         clk = REPEAT(' ', ifmtk)                               ! create the equivalent in blank string 
     275         WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(cdline) 
     276      ELSE 
     277         WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1      ! how many digits to we need to write jpk? (we decide max = 9) 
     278         !!! WRITE(clk, '(i'//clfmt//')') kloc(3)               ! this is creating a compilation error with AGRIF 
     279         cl4 = '(i'//clfmt//')'   ;   WRITE(clk, cl4) kloc(3)   ! this is ok with AGRIF 
     280         WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj),    TRIM(clk), TRIM(cdline) 
     281      ENDIF 
     282      ! 
     2839100  FORMAT('MPI rank ', a) 
     2849200  FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 
     2859300  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j   ', a, ' ', a, ' ', a, ' ', a) 
     2869400  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 
     287      ! 
     288   END SUBROUTINE wrt_line 
     289 
    230290 
    231291   !!====================================================================== 
  • NEMO/branches/2020/r12581_ticket2418/tests/STATION_ASF/MY_SRC/stpctl.F90

    r12718 r12840  
    6262      INTEGER                         ::   ji                                    ! dummy loop indices 
    6363      INTEGER                         ::   idtime, istatus 
    64       INTEGER, DIMENSION(2,3)         ::   iloc                                  ! min/max loc indices 
     64      INTEGER , DIMENSION(4)          ::   iareasum, iareamin, iareamax 
     65      INTEGER , DIMENSION(3,3)        ::   iloc                                  ! min/max loc indices 
    6566      REAL(wp)                        ::   zzz                                   ! local real  
    66       REAL(wp), DIMENSION(4)          ::   zmax, zmaxlocal, zarea 
     67      REAL(wp), DIMENSION(4)          ::   zmax, zmaxlocal 
    6768      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
    6869      LOGICAL, DIMENSION(jpi,jpj)     ::   llmsk 
     
    138139         &  ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN   ! NaN encounter in the tests 
    139140         ! 
     141         iloc(:,:) = 0 
    140142         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
    141143            ! first: close the netcdf file, so we can read it 
     
    146148            CALL mpp_minloc( 'stpctl',ABS( emp(:,:) ), tmask(:,:,1), zzz, iloc(1:2,3) ) 
    147149            ! find which subdomain has the max. 
    148             zarea(:) = 0._wp 
     150            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    149151            DO ji = 1, 4 
    150                IF( zmaxlocal(ji) == zmax(ji) )   zarea(ji) = narea  
     152               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     153                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     154               ENDIF 
    151155            END DO 
    152             CALL mpp_max( "stpctl", zarea )         ! max over the global domain 
     156            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     157            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     158            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
    153159         ELSE                    ! find local min and max locations: 
    154160            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
     
    156162            iloc(1:2,2) = MAXLOC( ABS( qns(:,:) ), mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    157163            iloc(1:2,3) = MINLOC( ABS( emp(:,:) ), mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    158             zarea(:) = narea     ! this is local information 
     164            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    159165         ENDIF 
    160166         ! 
    161167         WRITE(ctmp1,*) ' stp_ctl: |tau_mod| > 5 N/m2  or  |qns| > 2000 W/m2  or |emp| > 1.E-3 or  NaN encounter in the tests' 
    162          WRITE(ctmp2,9100) kt, ' |tau| max', zmax(1), iloc(1,1), iloc(2,1), NINT(zarea(1))-1 
    163          WRITE(ctmp3,9100) kt, ' |qns| max', zmax(2), iloc(1,2), iloc(2,3), NINT(zarea(2))-1 
    164          WRITE(ctmp4,9100) kt, '  emp  max', zmax(3), iloc(1,2), iloc(2,3), NINT(zarea(3))-1 
     168         CALL wrt_line( ctmp2, kt, '|tau| max',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     169         CALL wrt_line( ctmp3, kt, '|qns| max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     170         CALL wrt_line( ctmp4, kt, 'emp   max',  zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
    165171         IF( Agrif_Root() ) THEN 
    166172            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
     
    173179         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    174180            IF(lwp)   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    175          ELSE   ! only mpi subdomains with errors are here -> STOP now 
     181         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
    176182            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    177183         ENDIF 
     
    182188      ENDIF 
    183189      ! 
    184 9100  FORMAT(' kt ',i8,a,1pg11.4,' at i j',2i6,' MPI rank',i6) 
    1851909500  FORMAT(' it :', i8, '    tau_max: ', D23.16, ' |qns|_max: ', D23.16,' |emp|_max: ', D23.16) 
    186191      ! 
    187192   END SUBROUTINE stp_ctl 
     193 
     194 
     195   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
     196      !!---------------------------------------------------------------------- 
     197      !!                     ***  ROUTINE wrt_line  *** 
     198      !! 
     199      !! ** Purpose :   write information line 
     200      !! 
     201      !!---------------------------------------------------------------------- 
     202      CHARACTER(len=*),      INTENT(  out) ::   cdline 
     203      CHARACTER(len=*),      INTENT(in   ) ::   cdprefix 
     204      REAL(wp),              INTENT(in   ) ::   pval 
     205      INTEGER, DIMENSION(3), INTENT(in   ) ::   kloc 
     206      INTEGER,               INTENT(in   ) ::   kt, ksum, kmin, kmax 
     207      ! 
     208      CHARACTER(len=9) ::   clkt, clsum, clmin, clmax 
     209      CHARACTER(len=9) ::   cli, clj, clk 
     210      CHARACTER(len=1) ::   clfmt 
     211      CHARACTER(len=4) ::   cl4   ! needed to be able to compile with Agrif, I don't know why 
     212      INTEGER          ::   ifmtk 
     213      !!---------------------------------------------------------------------- 
     214      WRITE(clkt , '(i9)') kt 
     215       
     216      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij  ,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     217      !!! WRITE(clsum, '(i'//clfmt//')') ksum                   ! this is creating a compilation error with AGRIF 
     218      cl4 = '(i'//clfmt//')'   ;   WRITE(clsum, cl4) ksum 
     219      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij-1,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     220      cl4 = '(i'//clfmt//')'   ;   WRITE(clmin, cl4) kmin-1 
     221                                   WRITE(clmax, cl4) kmax-1 
     222      ! 
     223      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1      ! how many digits to we need to write jpiglo? (we decide max = 9) 
     224      cl4 = '(i'//clfmt//')'   ;   WRITE(cli, cl4) kloc(1)      ! this is ok with AGRIF 
     225      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1      ! how many digits to we need to write jpjglo? (we decide max = 9) 
     226      cl4 = '(i'//clfmt//')'   ;   WRITE(clj, cl4) kloc(2)      ! this is ok with AGRIF 
     227      ! 
     228      IF( ksum == 1 ) THEN   ;   WRITE(cdline,9100) TRIM(clmin) 
     229      ELSE                   ;   WRITE(cdline,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) 
     230      ENDIF 
     231      IF(kloc(3) == 0) THEN 
     232         ifmtk = INT(LOG10(REAL(jpk,wp))) + 1                   ! how many digits to we need to write jpk? (we decide max = 9) 
     233         clk = REPEAT(' ', ifmtk)                               ! create the equivalent in blank string 
     234         WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(cdline) 
     235      ELSE 
     236         WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1      ! how many digits to we need to write jpk? (we decide max = 9) 
     237         !!! WRITE(clk, '(i'//clfmt//')') kloc(3)               ! this is creating a compilation error with AGRIF 
     238         cl4 = '(i'//clfmt//')'   ;   WRITE(clk, cl4) kloc(3)   ! this is ok with AGRIF 
     239         WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj),    TRIM(clk), TRIM(cdline) 
     240      ENDIF 
     241      ! 
     2429100  FORMAT('MPI rank ', a) 
     2439200  FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 
     2449300  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j   ', a, ' ', a, ' ', a, ' ', a) 
     2459400  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 
     246      ! 
     247   END SUBROUTINE wrt_line 
     248 
    188249 
    189250   !!====================================================================== 
Note: See TracChangeset for help on using the changeset viewer.