Changeset 12840
- Timestamp:
- 2020-05-01T10:58:58+02:00 (3 years ago)
- Location:
- NEMO/branches/2020/r12581_ticket2418
- Files:
-
- 11 edited
-
src/OCE/ICB/icbrst.F90 (modified) (2 diffs)
-
src/OCE/ICB/icbtrj.F90 (modified) (2 diffs)
-
src/OCE/IOM/iom_nf90.F90 (modified) (2 diffs)
-
src/OCE/LBC/lib_mpp.F90 (modified) (3 diffs)
-
src/OCE/OBS/obs_grid.F90 (modified) (2 diffs)
-
src/OCE/OBS/obs_write.F90 (modified) (4 diffs)
-
src/OCE/STO/stopar.F90 (modified) (5 diffs)
-
src/OCE/stpctl.F90 (modified) (6 diffs)
-
src/SAS/stpctl.F90 (modified) (6 diffs)
-
tests/CANAL/MY_SRC/stpctl.F90 (modified) (5 diffs)
-
tests/STATION_ASF/MY_SRC/stpctl.F90 (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/r12581_ticket2418/src/OCE/ICB/icbrst.F90
r12472 r12840 188 188 ! 189 189 INTEGER :: jn ! dummy loop index 190 INTEGER :: idg ! number of digits 190 191 INTEGER :: ix_dim, iy_dim, ik_dim, in_dim 191 192 CHARACTER(len=256) :: cl_path 192 193 CHARACTER(len=256) :: cl_filename 193 194 CHARACTER(len=256) :: cl_kt 195 CHARACTER(LEN=12 ) :: clfmt ! writing format 194 196 TYPE(iceberg), POINTER :: this 195 197 TYPE(point) , POINTER :: pt … … 213 215 cl_filename = TRIM(cexper)//"_"//TRIM(ADJUSTL(cl_kt))//"_"//TRIM(cn_icbrst_out) 214 216 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' 216 220 ELSE 217 221 WRITE(cl_filename,'(A,".nc")') TRIM(cl_filename) -
NEMO/branches/2020/r12581_ticket2418/src/OCE/ICB/icbtrj.F90
r12489 r12840 62 62 ! 63 63 INTEGER :: iret, iyear, imonth, iday 64 INTEGER :: idg ! number of digits 64 65 REAL(wp) :: zfjulday, zsec 65 66 CHARACTER(len=80) :: cl_filename 67 CHARACTER(LEN=12) :: clfmt ! writing format 66 68 CHARACTER(LEN=20) :: cldate_ini, cldate_end 67 69 TYPE(iceberg), POINTER :: this … … 80 82 81 83 ! 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) 86 91 ENDIF 87 92 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 62 62 CHARACTER(LEN=256) :: clinfo ! info character 63 63 CHARACTER(LEN=256) :: cltmp ! temporary character 64 CHARACTER(LEN=12 ) :: clfmt ! writing format 64 65 CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open 66 INTEGER :: idg ! number of digits 65 67 INTEGER :: iln ! lengths of character 66 68 INTEGER :: istop ! temporary storage of nstop … … 109 111 IF( ldwrt ) THEN !* the file should be open in write mode so we create it... 110 112 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' 112 116 cdname = TRIM(cltmp) 113 117 ENDIF -
NEMO/branches/2020/r12581_ticket2418/src/OCE/LBC/lib_mpp.F90
r12684 r12840 1112 1112 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1113 1113 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 1114 1118 !!---------------------------------------------------------------------- 1115 1119 ! 1116 1120 nstop = nstop + 1 1117 1121 ! 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 1120 1133 ! 1121 1134 WRITE(numout,*) … … 1209 1222 ! 1210 1223 CHARACTER(len=80) :: clfile 1224 CHARACTER(LEN=10) :: clfmt ! writing format 1211 1225 INTEGER :: iost 1226 INTEGER :: idg ! number of digits 1212 1227 !!---------------------------------------------------------------------- 1213 1228 ! … … 1216 1231 clfile = TRIM(cdfile) 1217 1232 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 1219 1238 ENDIF 1220 1239 #if defined key_agrif -
NEMO/branches/2020/r12581_ticket2418/src/OCE/OBS/obs_grid.F90
r10068 r12840 684 684 & fhistx1, fhistx2, fhisty1, fhisty2 685 685 REAL(wp) :: histtol 686 686 CHARACTER(LEN=26) :: clfmt ! writing format 687 INTEGER :: idg ! number of digits 688 687 689 IF (ln_grid_search_lookup) THEN 688 690 … … 709 711 710 712 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' 713 714 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' 716 719 ENDIF 717 720 -
NEMO/branches/2020/r12581_ticket2418/src/OCE/OBS/obs_write.F90
r12377 r12840 86 86 CHARACTER(LEN=40) :: clfname 87 87 CHARACTER(LEN=10) :: clfiletype 88 CHARACTER(LEN=12) :: clfmt ! writing format 89 INTEGER :: idg ! number of digits 88 90 INTEGER :: ilevel 89 91 INTEGER :: jvar … … 181 183 fbdata%caddname(1) = 'Hx' 182 184 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' 184 188 185 189 IF(lwp) THEN … … 326 330 CHARACTER(LEN=10) :: clfiletype 327 331 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 332 CHARACTER(LEN=12) :: clfmt ! writing format 333 INTEGER :: idg ! number of digits 328 334 INTEGER :: jo 329 335 INTEGER :: ja … … 453 459 fbdata%caddname(1) = 'Hx' 454 460 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' 456 464 457 465 IF(lwp) THEN -
NEMO/branches/2020/r12581_ticket2418/src/OCE/STO/stopar.F90
r12377 r12840 684 684 !! ** Purpose : read stochastic parameters from restart file 685 685 !!---------------------------------------------------------------------- 686 INTEGER :: jsto, jseed 686 INTEGER :: jsto, jseed 687 INTEGER :: idg ! number of digits 687 688 INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type 688 689 REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (with same bits to save in restart) 689 690 CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name 690 691 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 692 694 !!---------------------------------------------------------------------- 693 695 … … 717 719 IF (ln_rstseed) THEN 718 720 ! 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)" 719 723 DO jseed = 1 , 4 720 WRITE(clseed(5:5) ,'(i1.1)') jseed721 WRITE(clseed(7: 10),'(i4.4)') narea722 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) ) 723 727 END DO 724 728 ziseed = TRANSFER( zrseed , ziseed) … … 742 746 INTEGER, INTENT(in) :: kt ! ocean time-step 743 747 !! 744 INTEGER :: jsto, jseed 748 INTEGER :: jsto, jseed 749 INTEGER :: idg ! number of digits 745 750 INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type 746 751 REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (with same bits to save in restart) … … 749 754 CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name 750 755 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 752 758 !!---------------------------------------------------------------------- 753 759 … … 771 777 CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) 772 778 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)" 773 781 DO jseed = 1 , 4 774 WRITE(clseed(5:5) ,'(i1.1)') jseed775 WRITE(clseed(7: 10),'(i4.4)') narea776 CALL iom_rstput( kt, nitrst, numstow, clseed 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) ) 777 785 END DO 778 786 ! 2D stochastic parameters -
NEMO/branches/2020/r12581_ticket2418/src/OCE/stpctl.F90
r12685 r12840 64 64 INTEGER :: ji ! dummy loop indices 65 65 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 67 68 REAL(wp) :: zzz ! local real 68 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal , zarea69 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal 69 70 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 70 71 LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk … … 176 177 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN ! NaN encounter in the tests 177 178 ! 179 iloc(:,:) = 0 178 180 IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 179 181 ! first: close the netcdf file, so we can read it … … 185 187 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,4) ) 186 188 ! find which subdomain has the max. 187 zarea(:) = 0._wp189 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 188 190 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 190 194 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 192 198 ELSE ! find local min and max locations: 193 199 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc … … 196 202 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 197 203 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 198 zarea(:) = narea! this is local information204 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 199 205 ENDIF 200 206 ! 201 207 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))-1203 WRITE(ctmp3,9200) kt, ' |U| max ', zmax(2), iloc(1,2), iloc(2,2), iloc(3,2), NINT(zarea(2))-1204 WRITE(ctmp4,9200) kt, ' Sal min ', -zmax(3), iloc(1,3), iloc(2,3), iloc(3,3), NINT(zarea(3))-1205 WRITE(ctmp5,9200) kt, ' Sal max ', zmax(4), iloc(1,4), iloc(2,4), iloc(3,4), NINT(zarea(4))-1208 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) ) 206 212 IF( Agrif_Root() ) THEN 207 213 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 214 220 IF( ll_colruns .or. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files 215 221 IF(lwp) CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 216 ELSE ! only mpi subdomains with errors are here -> STOP now222 ELSE ! only mpi subdomains with errors are here -> STOP now 217 223 CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 218 224 ENDIF … … 223 229 ENDIF 224 230 ! 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)227 231 9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 228 232 ! 229 233 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 ! 283 9100 FORMAT('MPI rank ', a) 284 9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 285 9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) 286 9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 287 ! 288 END SUBROUTINE wrt_line 289 230 290 231 291 !!====================================================================== -
NEMO/branches/2020/r12581_ticket2418/src/SAS/stpctl.F90
r12685 r12840 63 63 INTEGER :: ji ! dummy loop indices 64 64 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 66 67 REAL(wp) :: zzz ! local real 67 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal , zarea68 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal 68 69 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 69 70 LOGICAL, DIMENSION(jpi,jpj) :: llmsk … … 139 140 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN ! NaN encounter in the tests 140 141 ! 142 iloc(:,:) = 0 141 143 IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 142 144 ! first: close the netcdf file, so we can read it … … 147 149 CALL mpp_minloc( 'stpctl', tm_i(:,:) - 273.15_wp, tmask(:,:,1), zzz, iloc(1:2,3) ) 148 150 ! find which subdomain has the max. 149 zarea(:) = 0._wp151 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 150 152 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 152 156 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 154 160 ELSE ! find local min and max locations: 155 161 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc … … 157 163 iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 158 164 iloc(1:2,3) = MINLOC( tm_i(:,:) - 273.15_wp, mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 159 zarea(:) = narea! this is local information165 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 160 166 ENDIF 161 167 ! 162 168 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))-1164 WRITE(ctmp3,9100) kt, ' |ice_vel| max', zmax(2), iloc(1,2), iloc(2,3), NINT(zarea(2))-1165 WRITE(ctmp4,9100) kt, ' ice_temp min', -zmax(3), iloc(1,2), iloc(2,3), NINT(zarea(3))-1169 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) ) 166 172 IF( Agrif_Root() ) THEN 167 173 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 174 180 IF( ll_colruns .or. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files 175 181 IF(lwp) CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 176 ELSE ! only mpi subdomains with errors are here -> STOP now182 ELSE ! only mpi subdomains with errors are here -> STOP now 177 183 CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 178 184 ENDIF … … 183 189 ENDIF 184 190 ! 185 9100 FORMAT(' kt ',i8,a,1pg11.4,' at i j',2i6,' MPI rank',i6)186 191 9500 FORMAT(' it :', i8, ' vt_i_max: ', D23.16, ' |u|_max: ', D23.16,' tm_i_min: ', D23.16) 187 192 ! 188 193 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 ! 243 9100 FORMAT('MPI rank ', a) 244 9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 245 9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) 246 9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 247 ! 248 END SUBROUTINE wrt_line 249 189 250 190 251 !!====================================================================== -
NEMO/branches/2020/r12581_ticket2418/tests/CANAL/MY_SRC/stpctl.F90
r12685 r12840 64 64 INTEGER :: ji ! dummy loop indices 65 65 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 67 68 REAL(wp) :: zzz ! local real 68 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal , zarea69 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal 69 70 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 70 71 LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk … … 176 177 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN ! NaN encounter in the tests 177 178 ! 179 iloc(:,:) = 0 178 180 IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 179 181 ! first: close the netcdf file, so we can read it … … 182 184 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 183 185 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) ) 186 188 ! find which subdomain has the max. 187 zarea(:) = 0._wp189 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 188 190 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 190 194 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 192 198 ELSE ! find local min and max locations: 193 199 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 194 200 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 195 201 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 information199 ENDIF 200 ! 201 WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100or NaN encounter in the tests'202 WRITE(ctmp2,9100) kt, ' |ssh| max ', zmax(1), iloc(1,1), iloc(2,1), NINT(zarea(1))-1203 WRITE(ctmp3,9200) kt, ' |U| max ', zmax(2), iloc(1,2), iloc(2,2), iloc(3,2), NINT(zarea(2))-1204 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) ) 206 212 IF( Agrif_Root() ) THEN 207 213 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 213 219 ! 214 220 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 now217 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 ) 218 224 ENDIF 219 225 ! … … 223 229 ENDIF 224 230 ! 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)227 231 9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 228 232 ! 229 233 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 ! 283 9100 FORMAT('MPI rank ', a) 284 9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 285 9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) 286 9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 287 ! 288 END SUBROUTINE wrt_line 289 230 290 231 291 !!====================================================================== -
NEMO/branches/2020/r12581_ticket2418/tests/STATION_ASF/MY_SRC/stpctl.F90
r12718 r12840 62 62 INTEGER :: ji ! dummy loop indices 63 63 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 65 66 REAL(wp) :: zzz ! local real 66 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal , zarea67 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal 67 68 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 68 69 LOGICAL, DIMENSION(jpi,jpj) :: llmsk … … 138 139 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) THEN ! NaN encounter in the tests 139 140 ! 141 iloc(:,:) = 0 140 142 IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 141 143 ! first: close the netcdf file, so we can read it … … 146 148 CALL mpp_minloc( 'stpctl',ABS( emp(:,:) ), tmask(:,:,1), zzz, iloc(1:2,3) ) 147 149 ! find which subdomain has the max. 148 zarea(:) = 0._wp150 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 149 151 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 151 155 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 153 159 ELSE ! find local min and max locations: 154 160 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc … … 156 162 iloc(1:2,2) = MAXLOC( ABS( qns(:,:) ), mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 157 163 iloc(1:2,3) = MINLOC( ABS( emp(:,:) ), mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 158 zarea(:) = narea! this is local information164 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 159 165 ENDIF 160 166 ! 161 167 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))-1163 WRITE(ctmp3,9100) kt, ' |qns| max', zmax(2), iloc(1,2), iloc(2,3), NINT(zarea(2))-1164 WRITE(ctmp4,9100) kt, ' emp max', zmax(3), iloc(1,2), iloc(2,3), NINT(zarea(3))-1168 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) ) 165 171 IF( Agrif_Root() ) THEN 166 172 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 173 179 IF( ll_colruns .or. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files 174 180 IF(lwp) CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 175 ELSE ! only mpi subdomains with errors are here -> STOP now181 ELSE ! only mpi subdomains with errors are here -> STOP now 176 182 CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 177 183 ENDIF … … 182 188 ENDIF 183 189 ! 184 9100 FORMAT(' kt ',i8,a,1pg11.4,' at i j',2i6,' MPI rank',i6)185 190 9500 FORMAT(' it :', i8, ' tau_max: ', D23.16, ' |qns|_max: ', D23.16,' |emp|_max: ', D23.16) 186 191 ! 187 192 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 ! 242 9100 FORMAT('MPI rank ', a) 243 9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 244 9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) 245 9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 246 ! 247 END SUBROUTINE wrt_line 248 188 249 189 250 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
