Changeset 13899 for NEMO/branches/2020/tickets_icb_1900/src/SWE/domvvl.F90
- Timestamp:
- 2020-11-27T17:26:33+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/tickets_icb_1900
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/SWE/domvvl.F90 (modified) (24 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/tickets_icb_1900
- Property svn:externals
-
NEMO/branches/2020/tickets_icb_1900/src/SWE/domvvl.F90
r12983 r13899 205 205 gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb) 206 206 gdepw(:,:,1,Kbb) = 0.0_wp 207 DO_3D _11_11(2, jpk )207 DO_3D( 1, 1, 1, 1, 2, jpk ) 208 208 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 209 209 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) … … 253 253 ENDIF 254 254 IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator 255 DO_2D _11_11255 DO_2D( 1, 1, 1, 1 ) 256 256 !!gm case |gphi| >= 6 degrees is useless initialized just above by default 257 257 IF( ABS(gphit(ji,jj)) >= 6.) THEN … … 276 276 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 277 277 IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 278 ii0 = 103 ; ii1 = 111279 ij0 = 128 ; ij1 = 135 ;278 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 279 ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls 280 280 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp 281 281 frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rn_Dt … … 354 354 e3v(:,:,:,Kaa) = e3v(:,:,:,Kmm) 355 355 ! 356 DO_3D _11_11(1, jpk )356 DO_3D( 1, 1, 1, 1, 1, jpk ) 357 357 gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 358 358 gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) … … 415 415 LOGICAL :: ll_do_bclinic ! local logical 416 416 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 417 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 417 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t 418 LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk 418 419 !!---------------------------------------------------------------------- 419 420 ! … … 500 501 zwu(:,:) = 0._wp 501 502 zwv(:,:) = 0._wp 502 DO_3D _10_10(1, jpkm1 )503 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 503 504 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 504 505 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) … … 508 509 zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 509 510 END_3D 510 DO_2D _11_11511 DO_2D( 1, 1, 1, 1 ) 511 512 un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 512 513 vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 513 514 END_2D 514 DO_3D _00_00(1, jpkm1 )515 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 515 516 tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & 516 517 & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & … … 528 529 ! Maximum deformation control 529 530 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 531 ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) 530 532 ze3t(:,:,jpk) = 0._wp 531 533 DO jk = 1, jpkm1 532 534 ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 533 535 END DO 534 z_tmax = MAXVAL( ze3t(:,:,:) ) 535 CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 536 z_tmin = MINVAL( ze3t(:,:,:) ) 537 CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 536 ! 537 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 538 llmsk(Nie1: jpi,:,:) = .FALSE. 539 llmsk(:, 1:Njs1,:) = .FALSE. 540 llmsk(:,Nje1: jpj,:) = .FALSE. 541 ! 542 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 543 z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 544 z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 538 545 ! - ML - test: for the moment, stop simulation for too large e3_t variations 539 546 IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 540 IF( lk_mpp ) THEN 541 CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 542 CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 543 ELSE 544 ijk_max = MAXLOC( ze3t(:,:,:) ) 545 ijk_max(1) = ijk_max(1) + nimpp - 1 546 ijk_max(2) = ijk_max(2) + njmpp - 1 547 ijk_min = MINLOC( ze3t(:,:,:) ) 548 ijk_min(1) = ijk_min(1) + nimpp - 1 549 ijk_min(2) = ijk_min(2) + njmpp - 1 550 ENDIF 547 CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) 548 CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) 551 549 IF (lwp) THEN 552 550 WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax … … 557 555 ENDIF 558 556 ENDIF 557 DEALLOCATE( ze3t, llmsk ) 559 558 ! - ML - end test 560 559 ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below … … 697 696 LOGICAL :: ll_do_bclinic ! local logical 698 697 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 699 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t700 698 !!---------------------------------------------------------------------- 701 699 ! … … 831 829 gdepw(:,:,1,Kmm) = 0.0_wp 832 830 gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 833 DO_3D _11_11(2, jpk )831 DO_3D( 1, 1, 1, 1, 2, jpk ) 834 832 ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 835 833 ! 1 for jk = mikt … … 918 916 919 917 ! t- and w- points depth (set the isf depth as it is in the initial step) 920 DO_3D _11_11(1, jpk )918 DO_3D( 1, 1, 1, 1, 1, jpk ) 921 919 gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 922 920 gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) … … 1014 1012 ! 1015 1013 CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean 1016 DO_2D _00_001014 DO_2D( 0, 0, 0, 0 ) 1017 1015 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & 1018 1016 & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) … … 1025 1023 ! 1026 1024 CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean 1027 DO_2D _00_001025 DO_2D( 0, 0, 0, 0 ) 1028 1026 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & 1029 1027 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) … … 1036 1034 ! 1037 1035 CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean 1038 DO_2D _10_101036 DO_2D( 1, 0, 1, 0 ) 1039 1037 zc3(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & 1040 1038 & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & … … 1057 1055 CASE( 'UW' ) !* from U- to UW-point 1058 1056 ! 1059 DO_2D _00_001057 DO_2D( 0, 0, 0, 0 ) 1060 1058 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & 1061 1059 & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) … … 1068 1066 CASE( 'VW' ) !* from U- to UW-point : vertical simple mean 1069 1067 ! 1070 DO_2D _00_001068 DO_2D( 0, 0, 0, 0 ) 1071 1069 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & 1072 1070 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) … … 1107 1105 IF( ln_rstart ) THEN !* Read the restart file 1108 1106 CALL rst_read_open ! open the restart file if necessary 1109 CALL iom_get( numror, jpdom_auto glo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )1107 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios ) 1110 1108 ! 1111 1109 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 1120 1118 ! 1121 1119 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 1122 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )1123 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )1120 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 1121 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 1124 1122 ! needed to restart if land processor not computed 1125 1123 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 1135 1133 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 1136 1134 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1137 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )1135 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 1138 1136 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 1139 1137 l_1st_euler = .true. … … 1142 1140 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 1143 1141 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1144 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )1142 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 1145 1143 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 1146 1144 l_1st_euler = .true. … … 1167 1165 ! ! ----------------------- ! 1168 1166 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 1169 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )1170 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )1167 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 1168 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 1171 1169 ELSE ! one at least array is missing 1172 1170 tilde_e3t_b(:,:,:) = 0.0_wp … … 1177 1175 ! ! ------------ ! 1178 1176 IF( id5 > 0 ) THEN ! required array exists 1179 CALL iom_get( numror, jpdom_auto glo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )1177 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 1180 1178 ELSE ! array is missing 1181 1179 hdiv_lf(:,:,:) = 0.0_wp … … 1201 1199 ssh(:,:,Kbb) = -ssh_ref 1202 1200 1203 DO_2D _11_111201 DO_2D( 1, 1, 1, 1 ) 1204 1202 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 1205 1203 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
Note: See TracChangeset
for help on using the changeset viewer.
