Changeset 13337
- Timestamp:
- 2020-07-24T16:01:24+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep
- Files:
-
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/cfgs/SHARED/namelist_ref
r13286 r13337 645 645 ln_agrif_2way = .true. ! activate two way nesting 646 646 ln_init_chfrpar = .false. ! initialize child grids from parent 647 ln_vremap = .false. ! use vertical remapping 648 ln_chk_bathy = .false. ! =T check the parent bathymetry 647 649 ln_spc_dyn = .true. ! use 0 as special value for dynamics 648 650 rn_sponge_tra = 0.002 ! coefficient for tracer sponge layer [] … … 650 652 rn_trelax_tra = 0.01 ! inverse of relaxation time (in steps) for tracers [] 651 653 rn_trelax_dyn = 0.01 ! inverse of relaxation time (in steps) for dynamics [] 652 ln_chk_bathy = .false. ! =T check the parent bathymetry653 654 / 654 655 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce.F90
r13334 r13337 23 23 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: use zeros (.false.) or not (.true.) in 24 24 !: bdys dynamical fields interpolation 25 REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers 26 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 25 LOGICAL , PUBLIC :: ln_vremap = .FALSE. !: use vertical remapping 26 REAL(wp), PUBLIC :: rn_sponge_tra = 0.002 !: sponge coeff. for tracers 27 REAL(wp), PUBLIC :: rn_sponge_dyn = 0.002 !: sponge coeff. for dynamics 27 28 REAL(wp), PUBLIC :: rn_trelax_tra = 0.01 !: time relaxation parameter for tracers 28 29 REAL(wp), PUBLIC :: rn_trelax_dyn = 0.01 !: time relaxation parameter for momentum … … 76 77 REAL, PUBLIC :: sign_north 77 78 LOGICAL, PUBLIC :: l_ini_child = .FALSE. 78 # if defined key_vertical79 LOGICAL, PUBLIC :: l_vremap = .TRUE.80 # else81 79 LOGICAL, PUBLIC :: l_vremap = .FALSE. 82 # endif83 80 !$AGRIF_END_DO_NOT_TREAT 84 81 -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_interp.F90
r13334 r13337 47 47 PUBLIC interpht0, interpmbkt 48 48 PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90 49 PUBLIC agrif_check_bat 49 50 50 51 INTEGER :: bdy_tinterp = 0 … … 77 78 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 78 79 79 IF ( .NOT.Agrif_Parent(l n_1st_euler) ) &80 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 80 81 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 81 82 … … 120 121 END SUBROUTINE Agrif_istate_oce 121 122 123 122 124 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm ) 123 125 !!---------------------------------------------------------------------- … … 139 141 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 140 142 141 IF ( .NOT.Agrif_Parent(l n_1st_euler) ) &143 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 142 144 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 143 145 144 146 Kmm_a = Kmm 145 147 ssh(:,:,Kmm) = 0._wp 146 l_ini_child = .TRUE. 148 147 149 Agrif_SpecialValue = 0._wp 148 150 Agrif_UseSpecialValue = .TRUE. 151 l_ini_child = .TRUE. 152 ! 149 153 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 154 ! 150 155 Agrif_UseSpecialValue = .FALSE. 151 l_ini_child = .FALSE.156 l_ini_child = .FALSE. 152 157 CALL lbc_lnk( 'dom_vvl_rst', ssh(:,:,Kmm), 'T', 1._wp ) 153 158 … … 164 169 Agrif_SpecialValue = 0._wp 165 170 Agrif_UseSpecialValue = .TRUE. 171 l_vremap = ln_vremap 166 172 ! 167 173 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 168 174 ! 169 175 Agrif_UseSpecialValue = .FALSE. 176 l_vremap = .FALSE. 170 177 ! 171 178 END SUBROUTINE Agrif_tra … … 187 194 Agrif_SpecialValue = 0.0_wp 188 195 Agrif_UseSpecialValue = ln_spc_dyn 196 l_vremap = ln_vremap 189 197 ! 190 198 use_sign_north = .TRUE. … … 195 203 ! 196 204 Agrif_UseSpecialValue = .FALSE. 205 l_vremap = .FALSE. 197 206 ! 198 207 ! --- West --- ! … … 776 785 Agrif_SpecialValue = 0.e0 777 786 Agrif_UseSpecialValue = .TRUE. 787 l_vremap = ln_vremap 778 788 ! 779 789 CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) 780 790 ! 781 791 Agrif_UseSpecialValue = .FALSE. 792 l_vremap = .FALSE. 782 793 ! 783 794 END SUBROUTINE Agrif_avm … … 859 870 DO ji=i1,i2 860 871 ts(ji,jj,:,:,Krhs_a) = 0. 861 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts)862 872 N_in = mbkt_parent(ji,jj) 863 873 zhtot = 0._wp … … 1374 1384 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1375 1385 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1376 & mig0(ji), m ig0(jj), jk1386 & mig0(ji), mjg0(jj), jk 1377 1387 ! kindic_agr = kindic_agr + 1 1378 1388 ENDIF … … 1530 1540 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1531 1541 !!---------------------------------------------------------------------- 1532 !! *** ROUTINE interp sshn***1542 !! *** ROUTINE interpmbkt *** 1533 1543 !!---------------------------------------------------------------------- 1534 1544 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1549 1559 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1550 1560 !!---------------------------------------------------------------------- 1551 !! *** ROUTINE interp sshn***1561 !! *** ROUTINE interpht0 *** 1552 1562 !!---------------------------------------------------------------------- 1553 1563 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1564 1574 ! 1565 1575 END SUBROUTINE interpht0 1576 1577 SUBROUTINE Agrif_check_bat( iindic ) 1578 !!---------------------------------------------------------------------- 1579 !! *** ROUTINE Agrif_check_bat *** 1580 !!---------------------------------------------------------------------- 1581 INTEGER, INTENT(inout) :: iindic 1582 !! 1583 INTEGER :: ji, jj 1584 INTEGER :: istart, iend, jstart, jend, ispon 1585 !!---------------------------------------------------------------------- 1586 ! 1587 ! 1588 ! --- West --- ! 1589 IF(lk_west) THEN 1590 ispon = nn_sponge_len * Agrif_irhox() + 1 1591 istart = nn_hls + 2 ! halo + land + 1 1592 iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1593 jstart = nn_hls + 2 1594 jend = jpjglo - nn_hls - 1 1595 DO ji = mi0(istart), mi1(iend) 1596 DO jj = mj0(jstart), mj1(jend) 1597 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1598 END DO 1599 DO jj = mj0(jstart), mj1(jend-1) 1600 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1601 END DO 1602 END DO 1603 DO ji = mi0(istart), mi1(iend-1) 1604 DO jj = mj0(jstart), mj1(jend) 1605 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1606 END DO 1607 END DO 1608 ENDIF 1609 ! 1610 ! --- East --- ! 1611 IF(lk_east) THEN 1612 ispon = nn_sponge_len * Agrif_irhox() + 1 1613 istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1 1614 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1615 jstart = nn_hls + 2 1616 jend = jpjglo - nn_hls - 1 1617 DO ji = mi0(istart), mi1(iend) 1618 DO jj = mj0(jstart), mj1(jend) 1619 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1620 END DO 1621 DO jj = mj0(jstart), mj1(jend-1) 1622 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1623 END DO 1624 END DO 1625 DO ji = mi0(istart), mi1(iend-1) 1626 DO jj = mj0(jstart), mj1(jend) 1627 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1628 END DO 1629 END DO 1630 ENDIF 1631 ! 1632 ! --- South --- ! 1633 IF(lk_south) THEN 1634 ispon = nn_sponge_len * Agrif_irhoy() + 1 1635 jstart = nn_hls + 2 ! halo + land + 1 1636 jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1637 istart = nn_hls + 2 1638 iend = jpiglo - nn_hls - 1 1639 DO jj = mj0(jstart), mj1(jend) 1640 DO ji = mi0(istart), mi1(iend) 1641 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1642 END DO 1643 DO ji = mi0(istart), mi1(iend-1) 1644 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1645 END DO 1646 END DO 1647 DO jj = mj0(jstart), mj1(jend-1) 1648 DO ji = mi0(istart), mi1(iend) 1649 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1650 END DO 1651 END DO 1652 ENDIF 1653 ! 1654 ! --- North --- ! 1655 IF(lk_north) THEN 1656 ispon = nn_sponge_len * Agrif_irhoy() + 1 1657 jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1 1658 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1659 istart = nn_hls + 2 1660 iend = jpiglo - nn_hls - 1 1661 DO jj = mj0(jstart), mj1(jend) 1662 DO ji = mi0(istart), mi1(iend) 1663 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1664 END DO 1665 DO ji = mi0(istart), mi1(iend-1) 1666 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1667 END DO 1668 END DO 1669 DO jj = mj0(jstart), mj1(jend-1) 1670 DO ji = mi0(istart), mi1(iend) 1671 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1672 END DO 1673 END DO 1674 ENDIF 1675 ! 1676 END SUBROUTINE Agrif_check_bat 1566 1677 1567 1678 #else -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_sponge.F90
r13312 r13337 55 55 Agrif_SpecialValue = 0._wp 56 56 Agrif_UseSpecialValue = .TRUE. 57 l_vremap = ln_vremap 57 58 tabspongedone_tsn = .FALSE. 58 59 ! … … 60 61 ! 61 62 Agrif_UseSpecialValue = .FALSE. 63 l_vremap = .FALSE. 62 64 #endif 63 65 ! … … 80 82 Agrif_SpecialValue = 0._wp 81 83 Agrif_UseSpecialValue = ln_spc_dyn 84 l_vremap = ln_vremap 82 85 use_sign_north = .TRUE. 83 86 sign_north = -1._wp … … 93 96 Agrif_UseSpecialValue = .FALSE. 94 97 use_sign_north = .FALSE. 98 l_vremap = .FALSE. 95 99 #endif 96 100 ! … … 109 113 REAL(wp) :: z1_ispongearea, z1_jspongearea 110 114 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 111 #if defined key_vertical112 115 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampu 113 116 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampv 114 #endif115 REAL(wp), DIMENSION(jpjmax) :: zmskwest, zmskeast116 REAL(wp), DIMENSION(jpimax) :: zmsknorth, zmsksouth117 117 !!---------------------------------------------------------------------- 118 118 ! … … 130 130 #if defined SPONGE || defined SPONGE_TOP 131 131 IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 132 !133 ! Retrieve masks at open boundaries:134 135 IF( lk_west ) THEN ! --- West --- !136 ztabramp(:,:) = 0._wp137 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells138 DO ji = mi0(ind1), mi1(ind1)139 ztabramp(ji,:) = ssumask(ji,:)140 END DO141 zmskwest( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1)142 zmskwest(jpj+1:jpjmax) = 0._wp143 ENDIF144 IF( lk_east ) THEN ! --- East --- !145 ztabramp(:,:) = 0._wp146 ind1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells147 DO ji = mi0(ind1), mi1(ind1)148 ztabramp(ji,:) = ssumask(ji,:)149 END DO150 zmskeast( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1)151 zmskeast(jpj+1:jpjmax) = 0._wp152 ENDIF153 IF( lk_south ) THEN ! --- South --- !154 ztabramp(:,:) = 0._wp155 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells156 DO jj = mj0(ind1), mj1(ind1)157 ztabramp(:,jj) = ssvmask(:,jj)158 END DO159 zmsksouth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2)160 zmsksouth(jpi+1:jpimax) = 0._wp161 ENDIF162 IF( lk_north ) THEN ! --- North --- !163 ztabramp(:,:) = 0._wp164 ind1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells165 DO jj = mj0(ind1), mj1(ind1)166 ztabramp(:,jj) = ssvmask(:,jj)167 END DO168 zmsknorth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2)169 zmsknorth(jpi+1:jpimax) = 0._wp170 ENDIF171 172 ! JC: SPONGE MASKING TO BE SORTED OUT:173 zmskwest(:) = 1._wp174 zmskeast(:) = 1._wp175 zmsksouth(:) = 1._wp176 zmsknorth(:) = 1._wp177 #if defined key_mpp_mpi178 ! CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax )179 ! CALL mpp_max( 'AGRIF_Sponge', zmskeast(:) , jpjmax )180 ! CALL mpp_max( 'AGRIF_Sponge', zmsksouth(:), jpimax )181 ! CALL mpp_max( 'AGRIF_Sponge', zmsknorth(:), jpimax )182 #endif183 184 132 ! Define ramp from boundaries towards domain interior at T-points 185 133 ! Store it in ztabramp … … 201 149 DO ji = mi0(ind1), mi1(ind2) 202 150 DO jj = 1, jpj 203 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea * zmskwest(jj)151 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea 204 152 END DO 205 153 END DO … … 209 157 DO ji = mi0(ind1), mi1(ind2) 210 158 DO jj = 1, jpj 211 ztabramp(ji,jj) = zmskwest(jj)159 ztabramp(ji,jj) = 1._wp 212 160 END DO 213 161 END DO … … 218 166 DO ji = mi0(ind1), mi1(ind2) 219 167 DO jj = 1, jpj 220 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) * zmskeast(jj)168 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) 221 169 END DO 222 170 END DO … … 226 174 DO ji = mi0(ind1), mi1(ind2) 227 175 DO jj = 1, jpj 228 ztabramp(ji,jj) = zmskeast(jj)176 ztabramp(ji,jj) = 1._wp 229 177 END DO 230 178 END DO … … 235 183 DO jj = mj0(ind1), mj1(ind2) 236 184 DO ji = 1, jpi 237 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) * zmsksouth(ji)185 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) 238 186 END DO 239 187 END DO … … 243 191 DO jj = mj0(ind1), mj1(ind2) 244 192 DO ji = 1, jpi 245 ztabramp(ji,jj) = zmsksouth(ji)193 ztabramp(ji,jj) = 1._wp 246 194 END DO 247 195 END DO … … 252 200 DO jj = mj0(ind1), mj1(ind2) 253 201 DO ji = 1, jpi 254 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) * zmsknorth(ji)202 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) 255 203 END DO 256 204 END DO … … 260 208 DO jj = mj0(ind1), mj1(ind2) 261 209 DO ji = 1, jpi 262 ztabramp(ji,jj) = zmsknorth(ji)210 ztabramp(ji,jj) = 1._wp 263 211 END DO 264 212 END DO … … 303 251 ENDIF 304 252 305 #if defined key_vertical306 253 ! Remove vertical interpolation where not needed: 307 254 DO_2D( 0, 0, 0, 0 ) … … 327 274 mbku_parent(:,:) = NINT( ztabrampu(:,:) ) 328 275 mbkv_parent(:,:) = NINT( ztabrampv(:,:) ) 329 #endif330 276 ! 331 277 #endif … … 366 312 END DO 367 313 368 # if defined key_vertical 369 ! Interpolate thicknesses 370 ! Warning: these are masked, hence extrapolated prior interpolation. 371 DO jk=k1,k2 372 DO jj=j1,j2 373 DO ji=i1,i2 374 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a) 314 IF ( l_vremap ) THEN 315 316 ! Interpolate thicknesses 317 ! Warning: these are masked, hence extrapolated prior interpolation. 318 DO jk=k1,k2 319 DO jj=j1,j2 320 DO ji=i1,i2 321 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a) 322 END DO 375 323 END DO 376 324 END DO 377 END DO 378 379 ! Extrapolate thicknesses in partial bottom cells: 380 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 381 IF (ln_zps) THEN 382 DO jj=j1,j2 383 DO ji=i1,i2 384 jk = mbkt(ji,jj) 385 tabres(ji,jj,jk,jpts+1) = 0._wp 386 END DO 387 END DO 325 326 ! Extrapolate thicknesses in partial bottom cells: 327 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 328 IF (ln_zps) THEN 329 DO jj=j1,j2 330 DO ji=i1,i2 331 jk = mbkt(ji,jj) 332 tabres(ji,jj,jk,jpts+1) = 0._wp 333 END DO 334 END DO 335 END IF 336 337 ! Save ssh at last level: 338 IF (.NOT.ln_linssh) THEN 339 tabres(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1) 340 ELSE 341 tabres(i1:i2,j1:j2,k2,jpts+1) = 0._wp 342 END IF 388 343 END IF 389 390 ! Save ssh at last level:391 IF (.NOT.ln_linssh) THEN392 tabres(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1)393 ELSE394 tabres(i1:i2,j1:j2,k2,jpts+1) = 0._wp395 END IF396 # endif397 344 398 345 ELSE 399 346 ! 400 # if defined key_vertical 401 402 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 403 404 DO jj=j1,j2 405 DO ji=i1,i2 406 tabres_child(ji,jj,:,:) = 0._wp 407 N_in = mbkt_parent(ji,jj) 408 zhtot = 0._wp 409 DO jk=1,N_in !k2 = jpk of parent grid 410 IF (jk==N_in) THEN 411 h_in(jk) = ht0_parent(ji,jj) + tabres(ji,jj,k2,n2) - zhtot 347 IF ( l_vremap ) THEN 348 349 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 350 351 DO jj=j1,j2 352 DO ji=i1,i2 353 tabres_child(ji,jj,:,:) = 0._wp 354 N_in = mbkt_parent(ji,jj) 355 zhtot = 0._wp 356 DO jk=1,N_in !k2 = jpk of parent grid 357 IF (jk==N_in) THEN 358 h_in(jk) = ht0_parent(ji,jj) + tabres(ji,jj,k2,n2) - zhtot 359 ELSE 360 h_in(jk) = tabres(ji,jj,jk,n2) 361 END IF 362 zhtot = zhtot + h_in(jk) 363 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 364 END DO 365 N_out = 0 366 DO jk=1,jpk ! jpk of child grid 367 IF (tmask(ji,jj,jk) == 0) EXIT 368 N_out = N_out + 1 369 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 370 END DO 371 372 ! Account for small differences in the free-surface 373 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 374 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 412 375 ELSE 413 h_in(jk) = tabres(ji,jj,jk,n2) 376 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 377 END IF 378 IF (N_in*N_out > 0) THEN 379 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 414 380 ENDIF 415 zhtot = zhtot + h_in(jk) 416 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 417 END DO 418 N_out = 0 419 DO jk=1,jpk ! jpk of child grid 420 IF (tmask(ji,jj,jk) == 0) EXIT 421 N_out = N_out + 1 422 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 423 END DO 424 425 ! Account for small differences in free-surface 426 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 427 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 428 ELSE 429 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 430 ENDIF 431 IF (N_in*N_out > 0) THEN 432 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 433 ENDIF 434 END DO 435 END DO 436 # endif 437 438 DO jj=j1,j2 439 DO ji=i1,i2 440 DO jk=1,jpkm1 441 # if defined key_vertical 442 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres_child(ji,jj,jk,1:jpts)) * tmask(ji,jj,jk) 443 # else 444 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 445 # endif 446 END DO 447 END DO 448 END DO 381 END DO 382 END DO 383 384 DO jj=j1,j2 385 DO ji=i1,i2 386 DO jk=1,jpkm1 387 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres_child(ji,jj,jk,1:jpts)) * tmask(ji,jj,jk) 388 END DO 389 END DO 390 END DO 391 392 ELSE 393 394 DO jj=j1,j2 395 DO ji=i1,i2 396 DO jk=1,jpkm1 397 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 398 END DO 399 END DO 400 END DO 401 END IF 449 402 450 403 DO jn = 1, jpts … … 528 481 DO ji=i1,i2 529 482 tabres(ji,jj,jk,m1) = uu(ji,jj,jk,Kbb_a) 530 # if defined key_vertical 531 tabres(ji,jj,jk,m2) = e3u(ji,jj,jk,Kbb_a)*umask(ji,jj,jk) 532 # endif 533 END DO 534 END DO 535 END DO 536 537 # if defined key_vertical 538 ! Extrapolate thicknesses in partial bottom cells: 539 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 540 IF (ln_zps) THEN 483 END DO 484 END DO 485 END DO 486 487 IF ( l_vremap ) THEN 488 489 DO jk=k1,k2 490 DO jj=j1,j2 491 DO ji=i1,i2 492 tabres(ji,jj,jk,m2) = e3u(ji,jj,jk,Kbb_a)*umask(ji,jj,jk) 493 END DO 494 END DO 495 END DO 496 497 ! Extrapolate thicknesses in partial bottom cells: 498 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 499 IF (ln_zps) THEN 500 DO jj=j1,j2 501 DO ji=i1,i2 502 jk = mbku(ji,jj) 503 tabres(ji,jj,jk,m2) = 0._wp 504 END DO 505 END DO 506 END IF 507 ! Save ssh at last level: 508 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 509 IF (.NOT.ln_linssh) THEN 510 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 511 DO jk=1,jpk 512 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3u(i1:i2,j1:j2,jk,Kbb_a) * umask(i1:i2,j1:j2,jk) 513 END DO 514 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hu_0(i1:i2,j1:j2) 515 END IF 516 END IF 517 518 ELSE 519 520 IF ( l_vremap ) THEN 521 522 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 523 541 524 DO jj=j1,j2 542 525 DO ji=i1,i2 543 jk = mbku(ji,jj) 544 tabres(ji,jj,jk,m2) = 0._wp 545 END DO 546 END DO 547 END IF 548 ! Save ssh at last level: 549 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 550 IF (.NOT.ln_linssh) THEN 551 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 552 DO jk=1,jpk 553 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3u(i1:i2,j1:j2,jk,Kbb_a) * umask(i1:i2,j1:j2,jk) 554 END DO 555 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hu_0(i1:i2,j1:j2) 556 END IF 557 # endif 558 559 ELSE 560 561 # if defined key_vertical 562 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 563 564 DO jj=j1,j2 565 DO ji=i1,i2 566 tabres_child(ji,jj,:) = 0._wp 567 N_in = mbku_parent(ji,jj) 568 zhtot = 0._wp 569 DO jk=1,N_in 570 IF (jk==N_in) THEN 571 h_in(jk) = hu0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 526 tabres_child(ji,jj,:) = 0._wp 527 N_in = mbku_parent(ji,jj) 528 zhtot = 0._wp 529 DO jk=1,N_in 530 IF (jk==N_in) THEN 531 h_in(jk) = hu0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 532 ELSE 533 h_in(jk) = tabres(ji,jj,jk,m2) 534 ENDIF 535 zhtot = zhtot + h_in(jk) 536 tabin(jk) = tabres(ji,jj,jk,m1) 537 END DO 538 ! 539 N_out = 0 540 DO jk=1,jpk 541 IF (umask(ji,jj,jk) == 0) EXIT 542 N_out = N_out + 1 543 h_out(N_out) = e3u(ji,jj,jk,Kbb_a) 544 END DO 545 546 ! Account for small differences in free-surface 547 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 548 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 572 549 ELSE 573 h_in( jk) = tabres(ji,jj,jk,m2)550 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 574 551 ENDIF 575 zhtot = zhtot + h_in(jk)576 tabin(jk) = tabres(ji,jj,jk,m1)577 END DO578 !579 N_out = 0580 DO jk=1,jpk581 IF (umask(ji,jj,jk) == 0) EXIT582 N_out = N_out + 1583 h_out(N_out) = e3u(ji,jj,jk,Kbb_a)584 END DO585 586 ! Account for small differences in free-surface587 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN588 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) )589 ELSE590 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) )591 ENDIF592 552 593 IF (N_in * N_out > 0) THEN 594 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 595 ENDIF 596 END DO 597 END DO 598 599 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 600 #else 601 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 602 #endif 553 IF (N_in * N_out > 0) THEN 554 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 555 ENDIF 556 END DO 557 END DO 558 559 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 560 561 ELSE 562 563 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 564 565 ENDIF 603 566 ! 604 567 DO jk = 1, jpkm1 ! Horizontal slab … … 705 668 DO ji=i1,i2 706 669 tabres(ji,jj,jk,m1) = vv(ji,jj,jk,Kbb_a) 707 # if defined key_vertical 708 tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v(ji,jj,jk,Kbb_a) 709 # endif 710 END DO 711 END DO 712 END DO 713 714 # if defined key_vertical 715 ! Extrapolate thicknesses in partial bottom cells: 716 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 717 IF (ln_zps) THEN 670 END DO 671 END DO 672 END DO 673 674 IF ( l_vremap ) THEN 675 676 DO jk=k1,k2 677 DO jj=j1,j2 678 DO ji=i1,i2 679 tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v(ji,jj,jk,Kbb_a) 680 END DO 681 END DO 682 END DO 683 ! Extrapolate thicknesses in partial bottom cells: 684 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 685 IF (ln_zps) THEN 686 DO jj=j1,j2 687 DO ji=i1,i2 688 jk = mbkv(ji,jj) 689 tabres(ji,jj,jk,m2) = 0._wp 690 END DO 691 END DO 692 END IF 693 ! Save ssh at last level: 694 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 695 IF (.NOT.ln_linssh) THEN 696 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 697 DO jk=1,jpk 698 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3v(i1:i2,j1:j2,jk,Kbb_a) * vmask(i1:i2,j1:j2,jk) 699 END DO 700 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hv_0(i1:i2,j1:j2) 701 END IF 702 703 END IF 704 705 ELSE 706 707 IF ( l_vremap ) THEN 708 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 718 709 DO jj=j1,j2 719 710 DO ji=i1,i2 720 jk = mbkv(ji,jj) 721 tabres(ji,jj,jk,m2) = 0._wp 722 END DO 723 END DO 724 END IF 725 ! Save ssh at last level: 726 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 727 IF (.NOT.ln_linssh) THEN 728 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 729 DO jk=1,jpk 730 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3v(i1:i2,j1:j2,jk,Kbb_a) * vmask(i1:i2,j1:j2,jk) 731 END DO 732 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hv_0(i1:i2,j1:j2) 733 END IF 734 # endif 735 736 ELSE 737 738 # if defined key_vertical 739 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 740 DO jj=j1,j2 741 DO ji=i1,i2 742 tabres_child(ji,jj,:) = 0._wp 743 N_in = mbkv_parent(ji,jj) 744 zhtot = 0._wp 745 DO jk=1,N_in 746 IF (jk==N_in) THEN 747 h_in(jk) = hv0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 711 tabres_child(ji,jj,:) = 0._wp 712 N_in = mbkv_parent(ji,jj) 713 zhtot = 0._wp 714 DO jk=1,N_in 715 IF (jk==N_in) THEN 716 h_in(jk) = hv0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 717 ELSE 718 h_in(jk) = tabres(ji,jj,jk,m2) 719 ENDIF 720 zhtot = zhtot + h_in(jk) 721 tabin(jk) = tabres(ji,jj,jk,m1) 722 END DO 723 ! 724 N_out = 0 725 DO jk=1,jpk 726 IF (vmask(ji,jj,jk) == 0) EXIT 727 N_out = N_out + 1 728 h_out(N_out) = e3v(ji,jj,jk,Kbb_a) 729 END DO 730 731 ! Account for small differences in free-surface 732 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 733 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 748 734 ELSE 749 h_in( jk) = tabres(ji,jj,jk,m2)735 h_in(1) = h_in(1) - ( sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 750 736 ENDIF 751 zhtot = zhtot + h_in(jk)752 tabin(jk) = tabres(ji,jj,jk,m1)753 END DO754 !755 N_out = 0756 DO jk=1,jpk757 IF (vmask(ji,jj,jk) == 0) EXIT758 N_out = N_out + 1759 h_out(N_out) = e3v(ji,jj,jk,Kbb_a)760 END DO761 762 ! Account for small differences in free-surface763 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN764 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) )765 ELSE766 h_in(1) = h_in(1) - ( sum(h_in(1:N_in))-sum(h_out(1:N_out)) )767 ENDIF768 737 769 IF (N_in * N_out > 0) THEN 770 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 771 ENDIF 772 END DO 773 END DO 774 775 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 776 # else 777 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 778 # endif 738 IF (N_in * N_out > 0) THEN 739 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 740 ENDIF 741 END DO 742 END DO 743 744 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 745 746 ELSE 747 748 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 749 750 ENDIF 779 751 ! 780 752 DO jk = 1, jpkm1 ! Horizontal slab -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_update.F90
r13286 r13337 50 50 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed() 51 51 52 #if defined key_vertical 53 ! Effect of this has to be carrefully checked 54 ! depending on what the nesting tools ensure for 55 ! volume conservation: 56 Agrif_UseSpecialValueInUpdate = .FALSE. 57 #else 58 Agrif_UseSpecialValueInUpdate = .TRUE. 59 #endif 52 Agrif_UseSpecialValueInUpdate = .NOT.l_vremap 60 53 Agrif_SpecialValueFineGrid = 0._wp 54 l_vremap = ln_vremap 61 55 ! 62 56 # if ! defined DECAL_FEEDBACK … … 71 65 ! 72 66 Agrif_UseSpecialValueInUpdate = .FALSE. 67 l_vremap = .FALSE. 73 68 ! 74 69 ! … … 86 81 Agrif_UseSpecialValueInUpdate = .FALSE. 87 82 Agrif_SpecialValueFineGrid = 0._wp 88 89 use_sign_north = .TRUE.90 sign_north = -1._wp83 l_vremap = ln_vremap 84 use_sign_north = .TRUE. 85 sign_north = -1._wp 91 86 92 87 ! … … 133 128 ! 134 129 use_sign_north = .FALSE. 130 ln_vremap = .FALSE. 135 131 ! 136 132 END SUBROUTINE Agrif_Update_Dyn … … 291 287 END SUBROUTINE dom_vvl_update_UVF 292 288 293 #if defined key_vertical294 289 295 290 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 311 306 ! 312 307 IF (before) THEN 313 !jc_alt 314 ! AGRIF_SpecialValue = -999._wp 315 DO jn = n1,n2-1 308 IF ( l_vremap ) THEN 309 DO jn = n1,n2-1 310 DO jk=k1,k2 311 DO jj=j1,j2 312 DO ji=i1,i2 313 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 314 END DO 315 END DO 316 END DO 317 END DO 316 318 DO jk=k1,k2 317 319 DO jj=j1,j2 318 320 DO ji=i1,i2 319 !jc_alt 320 ! tabres(ji,jj,jk,jn) = (ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 321 ! & * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1._wp) * 999._wp 322 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 321 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 323 322 END DO 324 323 END DO 325 324 END DO 326 END DO 327 DO jk=k1,k2 325 ELSE 326 DO jn = 1,jpts 327 DO jk=k1,k2 328 DO jj=j1,j2 329 DO ji=i1,i2 330 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 331 END DO 332 END DO 333 END DO 334 END DO 335 336 ENDIF 337 ELSE 338 IF ( l_vremap ) THEN 339 tabres_child(:,:,:,:) = 0._wp 340 AGRIF_SpecialValue = 0._wp 328 341 DO jj=j1,j2 329 342 DO ji=i1,i2 330 !jc_alt 331 ! tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) & 332 ! & + (tmask(ji,jj,jk) - 1._wp) * 999._wp 333 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 334 END DO 335 END DO 336 END DO 337 ELSE 338 tabres_child(:,:,:,:) = 0._wp 339 AGRIF_SpecialValue = 0._wp 340 DO jj=j1,j2 341 DO ji=i1,i2 342 N_in = 0 343 DO jk=k1,k2 !k2 = jpk of child grid 344 ! jc_alt 345 ! IF (tabres(ji,jj,jk,n2) < -900._wp ) EXIT 346 IF (tabres(ji,jj,jk,n2) == 0._wp ) EXIT 347 N_in = N_in + 1 348 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 349 h_in(N_in) = tabres(ji,jj,jk,n2) 343 N_in = 0 344 DO jk=k1,k2 !k2 = jpk of child grid 345 IF (tabres(ji,jj,jk,n2) == 0._wp ) EXIT 346 N_in = N_in + 1 347 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 348 h_in(N_in) = tabres(ji,jj,jk,n2) 349 ENDDO 350 N_out = 0 351 DO jk=1,jpk ! jpk of parent grid 352 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 353 N_out = N_out + 1 354 h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 355 ENDDO 356 IF (N_in*N_out > 0) THEN !Remove this? 357 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 358 ENDIF 350 359 ENDDO 351 N_out = 0352 DO jk=1,jpk ! jpk of parent grid353 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF354 N_out = N_out + 1355 h_out(N_out) = e3t(ji,jj,jk,Kmm_a)356 ENDDO357 IF (N_in*N_out > 0) THEN !Remove this?358 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts)359 ENDIF360 360 ENDDO 361 ENDDO 362 363 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 364 ! Add asselin part 361 362 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 363 ! Add asselin part 364 DO jn = 1,jpts 365 DO jk = 1, jpkm1 366 DO jj = j1, j2 367 DO ji = i1, i2 368 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 369 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 370 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 371 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 372 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 373 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 374 ENDIF 375 END DO 376 END DO 377 END DO 378 END DO 379 ENDIF 365 380 DO jn = 1,jpts 366 381 DO jk = 1, jpkm1 367 382 DO jj = j1, j2 368 383 DO ji = i1, i2 369 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 370 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 371 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 372 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 373 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 374 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 375 ENDIF 384 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 385 ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 386 END IF 376 387 END DO 377 388 END DO 378 389 END DO 379 390 END DO 380 ENDIF 381 DO jn = 1,jpts 382 DO jk = 1, jpkm1 383 DO jj = j1, j2 384 DO ji = i1, i2 385 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 386 ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 387 END IF 391 ELSE 392 DO jn = 1,jpts 393 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 394 & * tmask(i1:i2,j1:j2,k1:k2) 395 ENDDO 396 397 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 398 ! Add asselin part 399 DO jn = 1,jpts 400 DO jk = k1, k2 401 DO jj = j1, j2 402 DO ji = i1, i2 403 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 404 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 405 ztnu = tabres(ji,jj,jk,jn) 406 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 407 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 408 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 409 ENDIF 410 END DO 411 END DO 388 412 END DO 389 413 END DO 390 END DO 391 END DO 392 ! 414 ENDIF 415 DO jn = 1,jpts 416 DO jk=k1,k2 417 DO jj=j1,j2 418 DO ji=i1,i2 419 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 420 ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 421 END IF 422 END DO 423 END DO 424 END DO 425 END DO 426 ! 427 ENDIF 393 428 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 394 429 ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kbb_a) = ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kmm_a) … … 398 433 END SUBROUTINE updateTS 399 434 400 # else401 402 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )403 !!---------------------------------------------404 !! *** ROUTINE updateT ***405 !!---------------------------------------------406 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2407 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres408 LOGICAL, INTENT(in) :: before409 !!410 INTEGER :: ji,jj,jk,jn411 REAL(wp) :: ztb, ztnu, ztno412 !!---------------------------------------------413 !414 IF (before) THEN415 DO jn = 1,jpts416 DO jk=k1,k2417 DO jj=j1,j2418 DO ji=i1,i2419 !> jc tmp420 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)421 ! tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a)422 !< jc tmp423 END DO424 END DO425 END DO426 END DO427 ELSE428 !> jc tmp429 DO jn = 1,jpts430 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &431 & * tmask(i1:i2,j1:j2,k1:k2)432 ENDDO433 !< jc tmp434 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN435 ! Add asselin part436 DO jn = 1,jpts437 DO jk = k1, k2438 DO jj = j1, j2439 DO ji = i1, i2440 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN441 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used442 ztnu = tabres(ji,jj,jk,jn)443 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)444 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) &445 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)446 ENDIF447 END DO448 END DO449 END DO450 END DO451 ENDIF452 DO jn = 1,jpts453 DO jk=k1,k2454 DO jj=j1,j2455 DO ji=i1,i2456 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN457 ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)458 END IF459 END DO460 END DO461 END DO462 END DO463 !464 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN465 ts(i1:i2,j1:j2,k1:k2,1:jpts,Kbb_a) = ts(i1:i2,j1:j2,k1:k2,1:jpts,Kmm_a)466 ENDIF467 !468 ENDIF469 !470 END SUBROUTINE updateTS471 472 # endif473 474 # if defined key_vertical475 435 476 436 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 496 456 IF( before ) THEN 497 457 zrhoy = Agrif_Rhoy() 498 !jc_alt499 ! AGRIF_SpecialValue = -999._wp500 458 DO jk=k1,k2 459 tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) & 460 & * umask(i1:i2,j1:j2,jk) * uu(i1:i2,j1:j2,jk,Kmm_a) 461 END DO 462 463 IF ( l_vremap ) THEN 464 DO jk=k1,k2 465 tabres(i1:i2,j1:j2,jk,2) = zrhoy * umask(i1:i2,j1:j2,jk) * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) 466 END DO 467 ENDIF 468 469 ELSE 470 471 tabres_child(:,:,:) = 0._wp 472 AGRIF_SpecialValue = 0._wp 473 474 IF ( l_vremap ) THEN 475 501 476 DO jj=j1,j2 502 477 DO ji=i1,i2 503 !jc_alt 504 ! tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a) & 505 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 506 tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a) 507 !jc_alt 508 ! tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) & 509 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 510 tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 511 END DO 512 END DO 513 END DO 514 ELSE 515 tabres_child(:,:,:) = 0. 516 AGRIF_SpecialValue = 0._wp 517 DO jj=j1,j2 518 DO ji=i1,i2 519 N_in = 0 520 h_in(:) = 0._wp 521 tabin(:) = 0._wp 522 DO jk=k1,k2 !k2=jpk of child grid 523 !jc_alt 524 ! IF( tabres(ji,jj,jk,2) < -900._wp) EXIT 525 IF( tabres(ji,jj,jk,2) == 0.) EXIT 526 N_in = N_in + 1 527 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 528 h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj) 478 N_in = 0 479 h_in(:) = 0._wp 480 tabin(:) = 0._wp 481 DO jk=k1,k2 !k2=jpk of child grid 482 IF( tabres(ji,jj,jk,2) == 0.) EXIT 483 N_in = N_in + 1 484 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 485 h_in(N_in) = tabres(ji,jj,jk,2) * r1_e2u(ji,jj) 486 ENDDO 487 N_out = 0 488 DO jk=1,jpk 489 IF (umask(ji,jj,jk) == 0) EXIT 490 N_out = N_out + 1 491 h_out(N_out) = e3u(ji,jj,jk,Kmm_a) 492 ENDDO 493 IF (N_in * N_out > 0) THEN 494 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 495 excess = 0._wp 496 IF (h_diff < -1.e-4) THEN 497 DO jk=N_in,1,-1 498 thick = MIN(-1*h_diff, h_in(jk)) 499 excess = excess + tabin(jk)*thick*e2u(ji,jj) 500 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) 501 h_diff = h_diff + thick 502 IF ( h_diff == 0) THEN 503 N_in = jk 504 h_in(jk) = h_in(jk) - thick 505 EXIT 506 ENDIF 507 ENDDO 508 ENDIF 509 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 510 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) 511 ENDIF 529 512 ENDDO 530 N_out = 0531 DO jk=1,jpk532 IF (umask(ji,jj,jk) == 0) EXIT533 N_out = N_out + 1534 h_out(N_out) = e3u(ji,jj,jk,Kmm_a)535 ENDDO536 IF (N_in * N_out > 0) THEN537 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))538 excess = 0._wp539 IF (h_diff < -1.e-4) THEN540 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid.541 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.542 DO jk=N_in,1,-1543 thick = MIN(-1*h_diff, h_in(jk))544 excess = excess + tabin(jk)*thick*e2u(ji,jj)545 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))546 h_diff = h_diff + thick547 IF ( h_diff == 0) THEN548 N_in = jk549 h_in(jk) = h_in(jk) - thick550 EXIT551 ENDIF552 ENDDO553 ENDIF554 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1)555 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out))556 ENDIF557 513 ENDDO 558 ENDDO 514 515 ELSE 516 DO jk=1,jpk 517 DO jj=j1,j2 518 DO ji=i1,i2 519 tabres_child(ji,jj,jk) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm_a) 520 END DO 521 END DO 522 END DO 523 ENDIF 559 524 ! 560 525 DO jk=1,jpk … … 582 547 END SUBROUTINE updateu 583 548 584 #else585 586 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )587 !!---------------------------------------------588 !! *** ROUTINE updateu ***589 !!---------------------------------------------590 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2591 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres592 LOGICAL , INTENT(in ) :: before593 !594 INTEGER :: ji, jj, jk595 REAL(wp) :: zrhoy, zub, zunu, zuno596 !!---------------------------------------------597 !598 IF( before ) THEN599 zrhoy = Agrif_Rhoy()600 DO jk = k1, k2601 tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) * uu(i1:i2,j1:j2,jk,Kmm_a)602 END DO603 ELSE604 DO jk=k1,k2605 DO jj=j1,j2606 DO ji=i1,i2607 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj)608 !609 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN ! Add asselin part610 zub = uu(ji,jj,jk,Kbb_a) * e3u(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used611 zuno = uu(ji,jj,jk,Kmm_a) * e3u(ji,jj,jk,Krhs_a)612 zunu = tabres(ji,jj,jk,1)613 uu(ji,jj,jk,Kbb_a) = ( zub + rn_atfp * ( zunu - zuno) ) &614 & * umask(ji,jj,jk) / e3u(ji,jj,jk,Kbb_a)615 ENDIF616 !617 uu(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u(ji,jj,jk,Kmm_a)618 END DO619 END DO620 END DO621 !622 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN623 uu(i1:i2,j1:j2,k1:k2,Kbb_a) = uu(i1:i2,j1:j2,k1:k2,Kmm_a)624 ENDIF625 !626 ENDIF627 !628 END SUBROUTINE updateu629 630 # endif631 632 549 SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 633 550 !!--------------------------------------------- … … 674 591 END SUBROUTINE correct_u_bdy 675 592 676 # if defined key_vertical677 593 678 594 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 698 614 IF( before ) THEN 699 615 zrhox = Agrif_Rhox() 700 !jc_alt701 ! AGRIF_SpecialValue = -999._wp702 616 DO jk=k1,k2 617 tabres(i1:i2,j1:j2,jk,1) = zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Kmm_a) & 618 & * vmask(i1:i2,j1:j2,jk) * vv(i1:i2,j1:j2,jk,Kmm_a) 619 END DO 620 621 IF ( l_vremap ) THEN 622 DO jk=k1,k2 623 tabres(i1:i2,j1:j2,jk,2) = zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 624 END DO 625 ENDIF 626 627 ELSE 628 629 tabres_child(:,:,:) = 0._wp 630 AGRIF_SpecialValue = 0._wp 631 632 IF ( l_vremap ) THEN 633 703 634 DO jj=j1,j2 704 635 DO ji=i1,i2 705 !jc_alt 706 ! tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a) & 707 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 708 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a) 709 !jc_alt 710 ! tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) & 711 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 712 tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) 713 END DO 714 END DO 715 END DO 716 ELSE 717 tabres_child(:,:,:) = 0. 718 AGRIF_SpecialValue = 0._wp 719 DO jj=j1,j2 720 DO ji=i1,i2 721 N_in = 0 722 DO jk=k1,k2 723 !jc_alt 724 ! IF (tabres(ji,jj,jk,2) < -900._wp) EXIT 725 IF (tabres(ji,jj,jk,2) == 0) EXIT 726 N_in = N_in + 1 727 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 728 h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj) 729 ENDDO 730 N_out = 0 731 DO jk=1,jpk 732 IF (vmask(ji,jj,jk) == 0) EXIT 733 N_out = N_out + 1 734 h_out(N_out) = e3v(ji,jj,jk,Kmm_a) 735 ENDDO 736 IF (N_in * N_out > 0) THEN 737 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 738 excess = 0._wp 739 IF (h_diff < -1.e-4) then 636 N_in = 0 637 DO jk=k1,k2 638 IF (tabres(ji,jj,jk,2) == 0) EXIT 639 N_in = N_in + 1 640 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 641 h_in(N_in) = tabres(ji,jj,jk,2) * r1_e1v(ji,jj) 642 ENDDO 643 N_out = 0 644 DO jk=1,jpk 645 IF (vmask(ji,jj,jk) == 0) EXIT 646 N_out = N_out + 1 647 h_out(N_out) = e3v(ji,jj,jk,Kmm_a) 648 ENDDO 649 IF (N_in * N_out > 0) THEN 650 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 651 excess = 0._wp 652 IF (h_diff < -1.e-4) then 740 653 !Even if bathy at T points match it's possible for the V points to be deeper in the child grid. 741 654 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 742 DO jk=N_in,1,-1 743 thick = MIN(-1*h_diff, h_in(jk)) 744 excess = excess + tabin(jk)*thick*e2u(ji,jj) 745 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) 746 h_diff = h_diff + thick 747 IF ( h_diff == 0) THEN 748 N_in = jk 749 h_in(jk) = h_in(jk) - thick 750 EXIT 751 ENDIF 752 ENDDO 655 DO jk=N_in,1,-1 656 thick = MIN(-1*h_diff, h_in(jk)) 657 excess = excess + tabin(jk)*thick*e2u(ji,jj) 658 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) 659 h_diff = h_diff + thick 660 IF ( h_diff == 0) THEN 661 N_in = jk 662 h_in(jk) = h_in(jk) - thick 663 EXIT 664 ENDIF 665 ENDDO 666 ENDIF 667 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 668 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 753 669 ENDIF 754 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 755 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 756 ENDIF 670 ENDDO 757 671 ENDDO 758 ENDDO 672 673 ELSE 674 DO jk=1,jpk 675 DO jj=j1,j2 676 DO ji=i1,i2 677 tabres_child(ji,jj,jk) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm_a) 678 END DO 679 END DO 680 END DO 681 ENDIF 759 682 ! 760 683 DO jk=1,jpkm1 … … 782 705 END SUBROUTINE updatev 783 706 784 # else785 786 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before)787 !!---------------------------------------------788 !! *** ROUTINE updatev ***789 !!---------------------------------------------790 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2791 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres792 LOGICAL , INTENT(in ) :: before793 !794 INTEGER :: ji, jj, jk795 REAL(wp) :: zrhox, zvb, zvnu, zvno796 !!---------------------------------------------797 !798 IF (before) THEN799 zrhox = Agrif_Rhox()800 DO jk=k1,k2801 DO jj=j1,j2802 DO ji=i1,i2803 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)804 END DO805 END DO806 END DO807 ELSE808 DO jk=k1,k2809 DO jj=j1,j2810 DO ji=i1,i2811 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj)812 !813 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN ! Add asselin part814 zvb = vv(ji,jj,jk,Kbb_a) * e3v(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used815 zvno = vv(ji,jj,jk,Kmm_a) * e3v(ji,jj,jk,Krhs_a)816 zvnu = tabres(ji,jj,jk,1)817 vv(ji,jj,jk,Kbb_a) = ( zvb + rn_atfp * ( zvnu - zvno) ) &818 & * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kbb_a)819 ENDIF820 !821 vv(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kmm_a)822 END DO823 END DO824 END DO825 !826 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN827 vv(i1:i2,j1:j2,k1:k2,Kbb_a) = vv(i1:i2,j1:j2,k1:k2,Kmm_a)828 ENDIF829 !830 ENDIF831 !832 END SUBROUTINE updatev833 834 # endif835 707 836 708 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_top_interp.F90
r13216 r13337 43 43 Agrif_SpecialValue = 0._wp 44 44 Agrif_UseSpecialValue = .TRUE. 45 l_vremap = ln_vremap 45 46 ! 46 47 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 47 48 Agrif_UseSpecialValue = .FALSE. 49 l_vremap = .FALSE. 48 50 ! 49 51 END SUBROUTINE Agrif_trc … … 57 59 LOGICAL , INTENT(in ) :: before 58 60 ! 59 INTEGER :: ji, jj, jk, jn, ibdy, jbdy ! dummy loop indices 60 INTEGER :: imin, imax, jmin, jmax, N_in, N_out 61 REAL(wp) :: zrho, z1, z2, z3, z4, z5, z6, z7 62 61 INTEGER :: ji, jj, jk, jn ! dummy loop indices 62 INTEGER :: N_in, N_out 63 INTEGER :: item 63 64 ! vertical interpolation: 64 REAL(wp) , DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: ptab_child65 REAL(wp) :: zhtot 65 66 REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin 66 REAL(wp), DIMENSION(k1:k2) :: h_in 67 REAL(wp), DIMENSION(1:jpk) :: h_out 67 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in 68 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 68 69 !!---------------------------------------------------------------------- 69 70 70 IF( before ) THEN 71 IF( before ) THEN 72 73 item = Kmm_a 74 IF( l_ini_child ) Kmm_a = Kbb_a 75 71 76 DO jn = 1,jptra 72 77 DO jk=k1,k2 … … 77 82 END DO 78 83 END DO 79 END DO84 END DO 80 85 81 # if defined key_vertical 82 DO jk=k1,k2 83 DO jj=j1,j2 84 DO ji=i1,i2 85 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 86 END DO 87 END DO 88 END DO 89 # endif 86 IF( l_vremap .OR. l_ini_child) THEN 87 ! Interpolate thicknesses 88 ! Warning: these are masked, hence extrapolated prior interpolation. 89 DO jk=k1,k2 90 DO jj=j1,j2 91 DO ji=i1,i2 92 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 93 94 END DO 95 END DO 96 END DO 97 98 ! Extrapolate thicknesses in partial bottom cells: 99 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 100 IF (ln_zps) THEN 101 DO jj=j1,j2 102 DO ji=i1,i2 103 jk = mbkt(ji,jj) 104 ptab(ji,jj,jk,jptra+1) = 0._wp 105 END DO 106 END DO 107 END IF 108 109 ! Save ssh at last level: 110 IF (.NOT.ln_linssh) THEN 111 ptab(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 112 ELSE 113 ptab(i1:i2,j1:j2,k2,jptra+1) = 0._wp 114 END IF 115 ENDIF 116 Kmm_a = item 117 90 118 ELSE 119 item = Krhs_a 120 IF( l_ini_child ) Krhs_a = Kbb_a 91 121 92 # if defined key_vertical 93 DO jj=j1,j2 94 DO ji=i1,i2 95 ptab_child(ji,jj,:) = 0._wp 96 N_in = 0 97 DO jk=k1,k2 !k2 = jpk of parent grid 98 IF (ptab(ji,jj,jk,n2) == 0) EXIT 99 N_in = N_in + 1 100 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 101 h_in(N_in) = ptab(ji,jj,jk,n2) 122 IF( l_vremap .OR. l_ini_child ) THEN 123 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 124 125 DO jj=j1,j2 126 DO ji=i1,i2 127 tr(ji,jj,:,:,Krhs_a) = 0. 128 N_in = mbkt_parent(ji,jj) 129 zhtot = 0._wp 130 DO jk=1,N_in !k2 = jpk of parent grid 131 IF (jk==N_in) THEN 132 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 133 ELSE 134 h_in(jk) = ptab(ji,jj,jk,n2) 135 ENDIF 136 zhtot = zhtot + h_in(jk) 137 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 138 END DO 139 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 140 DO jk=2,N_in 141 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 142 END DO 143 144 N_out = 0 145 DO jk=1,jpk ! jpk of child grid 146 IF (tmask(ji,jj,jk) == 0._wp) EXIT 147 N_out = N_out + 1 148 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 149 END DO 150 151 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 152 DO jk=2,N_out 153 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 154 END DO 155 156 IF (N_in*N_out > 0) THEN 157 IF( l_ini_child ) THEN 158 CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), & 159 & z_out(1:N_out),N_in,N_out,jptra) 160 ELSE 161 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), & 162 & h_out(1:N_out),N_in,N_out,jptra) 163 ENDIF 164 ENDIF 102 165 END DO 103 N_out = 0 104 DO jk=1,jpk ! jpk of child grid 105 IF (tmask(ji,jj,jk) == 0) EXIT 106 N_out = N_out + 1 107 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 108 ENDDO 109 IF (N_in > 0) THEN 110 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,ptab_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 111 ENDIF 112 ENDDO 113 ENDDO 114 # else 115 ptab_child(i1:i2,j1:j2,1:jpk,1:jptra) = ptab(i1:i2,j1:j2,1:jpk,1:jptra) 116 # endif 117 ! 118 DO jn=1, jptra 119 tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 120 END DO 166 END DO 167 Krhs_a = item 168 169 ELSE 170 171 DO jn=1, jptra 172 tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 173 END DO 174 ENDIF 175 121 176 ENDIF 122 177 ! -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_user.F90
r13335 r13337 148 148 149 149 150 SUBROUTINE Agrif_Init_Domain ( Kbb, Kmm, Kaa )150 SUBROUTINE Agrif_Init_Domain 151 151 !!---------------------------------------------------------------------- 152 152 !! *** ROUTINE Agrif_Init_Domain *** … … 168 168 IMPLICIT NONE 169 169 ! 170 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa171 170 ! 172 171 LOGICAL :: check_namelist … … 186 185 mbkt_parent(:,:) = 0 187 186 ! 188 !CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )189 !CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)187 ! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 188 ! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 190 189 CALL Agrif_Init_Variable(ht0_id , procname=interpht0 ) 191 190 CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt) … … 214 213 zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) 215 214 END_2D 216 CALL lbc_lnk( 'Agrif_InitValues_ cont', zk, 'U', 1.0_wp )215 CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'U', 1.0_wp ) 217 216 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 218 217 DO_2D( 0, 0, 0, 0 ) 219 218 zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp ) 220 219 END_2D 221 CALL lbc_lnk( 'Agrif_InitValues_ cont', zk, 'V', 1.0_wp )220 CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'V', 1.0_wp ) 222 221 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 223 222 … … 231 230 ! 232 231 kindic_agr = 0 233 IF( .NOT. l _vremap ) THEN232 IF( .NOT. ln_vremap ) THEN 234 233 ! 235 234 ! check if tmask and vertical scale factors agree with parent in sponge area: … … 239 238 ! 240 239 ! In case of vertical interpolation, check only that total depths agree between child and parent: 241 DO ji = 1, jpi 242 DO jj = 1, jpj 243 IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 244 IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 245 IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 246 END DO 247 END DO 248 249 CALL mpp_sum( 'agrif_user', kindic_agr ) 240 241 CALL Agrif_check_bat( kindic_agr ) 242 243 CALL mpp_sum( 'agrif_InitValues_Domain', kindic_agr ) 250 244 IF( kindic_agr /= 0 ) THEN 251 245 CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') … … 257 251 ENDIF 258 252 259 IF( l _vremap ) THEN253 IF( ln_vremap ) THEN 260 254 ! Additional constrain that should be removed someday: 261 255 IF ( Agrif_Parent(jpk).GT.jpk ) THEN 262 CALL ctl_stop( ' With l _vremap, child grids must have jpk greater or equal to the parent value' )256 CALL ctl_stop( ' With ln_vremap, child grids must have jpk greater or equal to the parent value' ) 263 257 ENDIF 264 258 ENDIF … … 291 285 LOGICAL :: check_namelist 292 286 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 293 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace294 INTEGER :: ji, jj295 287 296 288 ! 1. Declaration of the type of variable which have to be interpolated … … 302 294 Agrif_SpecialValue = 0._wp 303 295 Agrif_UseSpecialValue = .TRUE. 296 l_vremap = ln_vremap 297 304 298 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn) 305 299 CALL Agrif_Sponge … … 342 336 ENDIF 343 337 Agrif_UseSpecialValue = .FALSE. 338 l_vremap = .FALSE. 344 339 345 340 !----------------- … … 398 393 ind2 = nn_hls + 2 + nbghostcells_x 399 394 ind3 = nn_hls + 2 + nbghostcells_y_s 400 # if defined key_vertical 401 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_id)402 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_sponge_id)395 396 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_id) 397 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_sponge_id) 403 398 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_interp_id) 404 399 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_interp_id) … … 407 402 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_sponge_id) 408 403 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_sponge_id) 409 # else 410 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 411 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_sponge_id) 412 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_interp_id) 413 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_interp_id) 414 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_update_id) 415 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_update_id) 416 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_sponge_id) 417 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_sponge_id) 418 # endif 404 419 405 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 420 406 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) … … 432 418 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 433 419 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 434 # if defined key_vertical435 420 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id) 436 # else437 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),avm_id)438 # endif439 421 ENDIF 440 422 … … 608 590 CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear) 609 591 CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear) 610 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear 611 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear 592 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear) 593 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear) 612 594 CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear) 613 595 CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear) … … 731 713 ind2 = nn_hls + 2 + nbghostcells_x 732 714 ind3 = nn_hls + 2 + nbghostcells_y_s 733 # if defined key_vertical 715 734 716 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_id) 735 717 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_sponge_id) 736 # else737 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id)738 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_sponge_id)739 # endif740 718 741 719 ! 2. Type of interpolation … … 788 766 INTEGER :: ios ! Local integer output status for namelist read 789 767 NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 790 & ln_spc_dyn, ln_ chk_bathy768 & ln_spc_dyn, ln_vremap, ln_chk_bathy 791 769 !!-------------------------------------------------------------------------------------- 792 770 ! … … 809 787 WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn 810 788 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 789 WRITE(numout,*) ' vertical remapping ln_vremap = ', ln_vremap 811 790 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 812 791 ENDIF -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/OCE/DOM/domain.F90
r13334 r13337 215 215 216 216 #if defined key_agrif 217 IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain ( Kbb, Kmm, Kaa )217 IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain 218 218 #endif 219 219 IF( ln_meshmask ) CALL dom_wri ! Create a domain file -
NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/OCE/DOM/istate.F90
r13334 r13337 88 88 #endif 89 89 90 #if defined key_agrif 90 91 IF ( (.NOT.Agrif_root()).AND.ln_init_chfrpar ) THEN 91 #if defined key_agrif92 92 numror = 0 ! define numror = 0 -> no restart file to read 93 93 ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) … … 169 169 ! 170 170 ENDIF 171 171 #if defined key_agrif 172 172 ENDIF 173 #endif 173 174 ! 174 175 ! Initialize "now" and "before" barotropic velocities:
Note: See TracChangeset
for help on using the changeset viewer.