Changeset 14200 for NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_interp.F90
- Timestamp:
- 2020-12-17T15:36:44+01:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/NST/agrif_oce_interp.F90
r14086 r14200 76 76 IF(lwp) WRITE(numout,*) ' ' 77 77 78 IF ( ln_rstart ) &79 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')80 81 78 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 82 79 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') … … 86 83 Agrif_UseSpecialValue = .TRUE. 87 84 88 ts(:,:,:,:,:) = 0.0_wp 89 uu(:,:,:,:) = 0.0_wp 90 vv(:,:,:,:) = 0.0_wp 91 ssh(:,:,:) = 0._wp 85 ts(:,:,:,:,Kbb) = 0.0_wp 86 uu(:,:,:,Kbb) = 0.0_wp 87 vv(:,:,:,Kbb) = 0.0_wp 92 88 93 89 Krhs_a = Kbb ; Kmm_a = Kbb 94 90 95 91 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 96 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)97 92 98 93 Agrif_UseSpecialValue = ln_spc_dyn … … 108 103 Krhs_a = Kaa ; Kmm_a = Kmm 109 104 110 ssh(:,:,Kbb) = ssh(:,:,Kbb) * tmask(:,:,1)111 112 105 DO jn = 1, jpts 113 106 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:) … … 118 111 CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 119 112 CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp ) 120 CALL lbc_lnk( 'agrif_istate_oce', ssh(:,:,Kbb), 'T', 1.0_wp )121 113 122 114 END SUBROUTINE Agrif_istate_oce 123 115 124 116 125 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm )117 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa ) 126 118 !!---------------------------------------------------------------------- 127 119 !! *** ROUTINE agrif_istate_ssh *** … … 132 124 IMPLICIT NONE 133 125 ! 134 INTEGER, INTENT(in) :: Kbb, Kmm 126 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 135 127 !!---------------------------------------------------------------------- 136 128 IF(lwp) WRITE(numout,*) ' ' … … 139 131 IF(lwp) WRITE(numout,*) ' ' 140 132 141 IF ( ln_rstart ) &142 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')143 144 133 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 145 134 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 146 135 147 Kmm_a = Kmm 148 ssh(:,:,Kmm) = 0._wp 149 136 Krhs_a = Kbb ; Kmm_a = Kbb 137 ! 150 138 Agrif_SpecialValue = 0._wp 151 139 Agrif_UseSpecialValue = .TRUE. 152 140 l_ini_child = .TRUE. 153 141 ! 142 ssh(:,:,Kbb) = 0._wp 154 143 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 155 144 ! 156 145 Agrif_UseSpecialValue = .FALSE. 157 146 l_ini_child = .FALSE. 158 CALL lbc_lnk( 'dom_vvl_rst', ssh(:,:,Kmm), 'T', 1._wp ) 147 ! 148 Krhs_a = Kaa ; Kmm_a = Kmm 149 ! 150 CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp ) 151 ! 152 ssh(:,:,Kmm) = ssh(:,:,Kbb) 153 ssh(:,:,Kaa) = 0._wp 159 154 160 155 END SUBROUTINE Agrif_istate_ssh … … 203 198 204 199 IF( .NOT.ln_dynspg_ts ) THEN ! Get transports 205 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 200 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 201 utint_stage(:,:) = 0 ; vtint_stage(:,:) = 0 206 202 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 207 203 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) … … 274 270 IF( .NOT.ln_dynspg_ts ) THEN 275 271 DO ji = mi0(ibdy1), mi1(ibdy2) 276 uu_b(ji,:,Krhs_a) = 0._wp277 DO jk = 1, jpkm1278 DO jj = 1, jpj279 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)280 END DO281 END DO282 272 DO jj = 1, jpj 283 273 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) … … 304 294 ! 305 295 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 306 ibdy2 = jpiglo - ( nn_hls + 1 ) ! 296 ibdy2 = jpiglo - ( nn_hls + 1 ) 297 ! 307 298 IF( .NOT.ln_dynspg_ts ) THEN 308 299 DO ji = mi0(ibdy1), mi1(ibdy2) 309 vv_b(ji,:,Krhs_a) = 0._wp310 DO jk = 1, jpkm1311 DO jj = 1, jpj312 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)313 END DO314 END DO315 300 DO jj = 1, jpj 316 301 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) … … 318 303 END DO 319 304 ENDIF 320 305 ! 321 306 DO ji = mi0(ibdy1), mi1(ibdy2) 322 307 zvb(ji,:) = 0._wp … … 345 330 IF( .NOT.ln_dynspg_ts ) THEN 346 331 DO jj = mj0(jbdy1), mj1(jbdy2) 347 vv_b(:,jj,Krhs_a) = 0._wp 348 DO jk = 1, jpkm1 349 DO ji = 1, jpi 350 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 351 END DO 352 END DO 353 DO ji=1,jpi 354 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 355 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 332 DO ji = 1, jpi 333 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 334 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 356 335 END DO 357 336 END DO … … 401 380 IF( .NOT.ln_dynspg_ts ) THEN 402 381 DO jj = mj0(jbdy1), mj1(jbdy2) 403 vv_b(:,jj,Krhs_a) = 0._wp 404 DO jk = 1, jpkm1 405 DO ji = 1, jpi 406 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 407 END DO 408 END DO 409 DO ji=1,jpi 382 DO ji = 1, jpi 410 383 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 411 384 END DO … … 432 405 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 433 406 jbdy2 = jpjglo - ( nn_hls + 1 ) 407 ! 434 408 IF( .NOT.ln_dynspg_ts ) THEN 435 409 DO jj = mj0(jbdy1), mj1(jbdy2) 436 uu_b(:,jj,Krhs_a) = 0._wp 437 DO jk = 1, jpkm1 438 DO ji = 1, jpi 439 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 440 END DO 441 END DO 442 DO ji=1,jpi 410 DO ji = 1, jpi 443 411 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 444 412 END DO 445 413 END DO 446 414 ENDIF 447 415 ! 448 416 DO jj = mj0(jbdy1), mj1(jbdy2) 449 417 zub(:,jj) = 0._wp … … 651 619 IF( ll_int_cons ) THEN ! Conservative interpolation 652 620 IF ( lk_tint2d_notinterp ) THEN 621 Agrif_UseSpecialValue = .FALSE. 653 622 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const ) 654 623 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 655 624 ! Divergence conserving correction terms: 656 CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )657 CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )625 IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor ) 626 IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor ) 658 627 ELSE 659 628 ! order matters here !!!!!! … … 990 959 ELSE 991 960 IF( l_ini_child ) THEN 992 ssh(i1:i2,j1:j2,K mm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)961 ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 993 962 ELSE 994 963 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) … … 1438 1407 ptab(:,:) = 0._wp 1439 1408 DO ji=i1+1,i2-1 1440 DO jj=j1+1,j2 1409 DO jj=j1+1,j2-1 1441 1410 ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj )*e1v(ji+1,jj ) & 1442 1411 & -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) & … … 1542 1511 ptab(:,:) = 0._wp 1543 1512 DO ji=i1+1,i2-1 1544 DO jj=j1+1,j2 1513 DO jj=j1+1,j2-1 1545 1514 ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji ,jj+1)*e2u(ji ,jj+1) & 1546 1515 & -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) &
Note: See TracChangeset
for help on using the changeset viewer.
