Changeset 14644 for NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynspg_ts.F90
- Timestamp:
- 2021-03-26T15:33:49+01:00 (3 years ago)
- Location:
- NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/DYN/dynspg_ts.F90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final
- Property svn:externals
-
old new 9 9 10 10 # SETTE 11 ^/utils/CI/sette _wave@13990sette11 ^/utils/CI/sette@14244 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/DYN/dynspg_ts.F90
r14286 r14644 119 119 120 120 121 SUBROUTINE dyn_spg_ts( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa )121 SUBROUTINE dyn_spg_ts( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) 122 122 !!---------------------------------------------------------------------- 123 123 !! … … 147 147 INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices 148 148 REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation 149 REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh ! SSH 150 REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b ! barotropic velocities at main time levels 149 REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh ! SSH 150 REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b ! barotropic velocities at main time levels 151 INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS 151 152 ! 152 153 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 168 169 REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points 169 170 REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes 170 #if defined key_qco171 REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v172 #endif171 !!st#if defined key_qco 172 !!st REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v 173 !!st#endif 173 174 ! 174 175 REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. … … 238 239 ! ! --------------------------- ! 239 240 #if defined key_qco 240 DO jk = 1 , jpk 241 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 242 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 243 END DO 244 ! 245 zu_frc(:,:) = SUM( ze3u(:,:,:) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 246 zv_frc(:,:) = SUM( ze3v(:,:,:) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 241 zu_frc(:,:) = SUM( e3u_0(:,:,: ) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu_0(:,:) 242 zv_frc(:,:) = SUM( e3v_0(:,:,: ) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv_0(:,:) 247 243 #else 248 zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu(:,:,Kmm)249 zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv(:,:,Kmm)244 zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu(:,:,Kmm) 245 zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv(:,:,Kmm) 250 246 #endif 251 247 ! … … 253 249 ! != U(Krhs) => baroclinic trend =! (remove its vertical mean) 254 250 DO jk = 1, jpkm1 ! ----------------------------- ! 255 uu(:,:,jk,Krhs) = (uu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk)256 vv(:,:,jk,Krhs) = (vv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk)251 puu(:,:,jk,Krhs) = ( puu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk) 252 pvv(:,:,jk,Krhs) = ( pvv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk) 257 253 END DO 258 254 … … 266 262 ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes 267 263 ! 268 ! !* 2D Coriolis trends 269 zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes 270 zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 271 ! 272 CALL dyn_cor_2d( CASTWP(ht(:,:)), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in 273 & zu_trd, zv_trd ) ! ==>> out 274 ! 275 DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend 276 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 277 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 278 END_2D 264 IF( .NOT. PRESENT(k_only_ADV) ) THEN !* remove the 2D Coriolis trend 265 zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes 266 zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 267 ! 268 CALL dyn_cor_2d( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in 269 & zu_trd, zv_trd ) ! ==>> out 270 ! 271 DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend 272 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 273 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 274 END_2D 275 ENDIF 279 276 ! 280 277 ! != Add bottom stress contribution from baroclinic velocities =! 281 278 ! ! ----------------------------------------------------------- ! 282 CALL dyn_drg_init( Kbb, Kmm, CASTWP(puu), CASTWP(pvv), puu_b ,pvv_b, zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients 279 IF( PRESENT(k_only_ADV) ) THEN !* only Advection in the RHS : provide the barotropic bottom drag coefficients 280 DO_2D( 0, 0, 0, 0 ) 281 zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 282 zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 283 END_2D 284 ELSE !* remove baroclinic drag AND provide the barotropic drag coefficients 285 CALL dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b, pvv_b, zu_frc, zv_frc, zCdU_u, zCdU_v ) 286 ENDIF 283 287 ! 284 288 ! != Add atmospheric pressure forcing =! … … 472 476 #if defined key_qcoTest_FluxForm 473 477 ! ! 'key_qcoTest_FluxForm' : simple ssh average 474 DO_2D( 1, 1, 1, 0) ! not jpi-column478 DO_2D( 1, 0, 1, 1 ) ! not jpi-column 475 479 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 476 480 END_2D 477 DO_2D( 1, 0, 1, 1)481 DO_2D( 1, 1, 1, 0 ) 478 482 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) 479 483 END_2D 480 484 #else 481 485 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 482 DO_2D( 1, 1, 1, 0) ! not jpi-column486 DO_2D( 1, 0, 1, 1 ) ! not jpi-column 483 487 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 484 488 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 485 489 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 486 490 END_2D 487 DO_2D( 1, 0, 1, 1) ! not jpj-row491 DO_2D( 1, 1, 1, 0 ) ! not jpj-row 488 492 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 489 493 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & … … 526 530 END_2D 527 531 ! 528 #if defined key_single 529 CALL lbc_lnk ( 'dynspg_ts', ssha_e, 'T', 1._wp ) 530 CALL lbc_lnk_multi( 'dynspg_ts', zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 531 #else 532 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 533 #endif 532 CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 534 533 ! 535 534 ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) … … 554 553 #if defined key_qcoTest_FluxForm 555 554 ! ! 'key_qcoTest_FluxForm' : simple ssh average 555 DO_2D( 1, 0, 1, 1 ) 556 zsshu_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji+1,jj ) ) * ssumask(ji,jj) 557 END_2D 556 558 DO_2D( 1, 1, 1, 0 ) 557 zsshu_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji+1,jj ) ) * ssumask(ji,jj)558 END_2D559 DO_2D( 1, 0, 1, 1 )560 559 zsshv_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) 561 560 END_2D … … 684 683 ! 685 684 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 686 CALL lbc_lnk _multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp &687 & 688 & 685 CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & 686 & , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp & 687 & , hur_e, 'U', 1._wp, hvr_e, 'V', 1._wp ) 689 688 ELSE 690 CALL lbc_lnk _multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp )689 CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) 691 690 ENDIF 692 691 ! ! open boundaries … … 782 781 END_2D 783 782 #endif 784 CALL lbc_lnk _multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions783 CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 785 784 ! 786 785 DO jk=1,jpkm1 … … 996 995 SUBROUTINE dyn_spg_ts_init 997 996 !!--------------------------------------------------------------------- 998 !! *** ROUTINE dyn_spg_ts_init *** 997 !! *** ROUTINE dyn_spg_ts_init ***dynspg_ts.F90.merge-right.r14642 999 998 !! 1000 999 !! ** Purpose : Set time splitting options … … 1270 1269 !!---------------------------------------------------------------------- 1271 1270 ! 1272 DO_2D( 1, 1, 1, 0) ! not jpi-column1271 DO_2D( 1, 0, 1, 1 ) ! not jpi-column 1273 1272 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1274 1273 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) … … 1278 1277 END_2D 1279 1278 ! 1280 DO_2D( 1, 0, 1, 1) ! not jpj-row1279 DO_2D( 1, 1, 1, 0 ) ! not jpj-row 1281 1280 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1282 1281 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1)
Note: See TracChangeset
for help on using the changeset viewer.
