- Timestamp:
- 2019-12-05T13:18:21+01:00 (4 years ago)
- Location:
- NEMO/branches/2019/UKMO_MERGE_2019/src/OCE/ISF
- Files:
-
- 1 edited
- 1 copied
-
. (copied) (copied from NEMO/branches/2019/ENHANCE-02_ISF_nemo_TEST_MERGE/src/OCE/ISF)
-
isfcpl.F90 (modified) (28 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/UKMO_MERGE_2019/src/OCE/ISF/isfcpl.F90
r11931 r12068 46 46 !!---------------------------------------------------------------------- 47 47 CONTAINS 48 SUBROUTINE isfcpl_init( )48 SUBROUTINE isfcpl_init(Kbb, Kmm, Kaa) 49 49 !!--------------------------------------------------------------------- 50 50 !! 51 !!--------------------------------------------------------------------- 52 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 51 53 !!--------------------------------------------------------------------- 52 54 INTEGER :: id … … 74 76 ELSE 75 77 ! extrapolation ssh 76 CALL isfcpl_ssh( )78 CALL isfcpl_ssh(Kbb, Kmm, Kaa) 77 79 ! 78 80 ! extrapolation tracer properties 79 CALL isfcpl_tra( )81 CALL isfcpl_tra(Kmm) 80 82 ! 81 83 ! correction of the horizontal divergence and associated temp. and salt content flux 82 84 ! Need to : - include in the cpl cons the risfcpl_vol/tsc contribution 83 85 ! - decide how to manage thickness level change in conservation 84 CALL isfcpl_vol( )86 CALL isfcpl_vol(Kmm) 85 87 ! 86 88 ! apply the 'conservation' method 87 IF ( ln_isfcpl_cons ) CALL isfcpl_cons( )89 IF ( ln_isfcpl_cons ) CALL isfcpl_cons(Kmm) 88 90 ! 89 91 END IF 90 92 ! 91 93 ! mask velocity properly (mask used in restart not compatible with new mask) 92 u n(:,:,:) = un(:,:,:) * umask(:,:,:)93 v n(:,:,:) = vn(:,:,:) * vmask(:,:,:)94 uu(:,:,:,Kmm) = uu(:,:,:,Kmm) * umask(:,:,:) 95 vv(:,:,:,Kmm) = vv(:,:,:,Kmm) * vmask(:,:,:) 94 96 ! 95 97 ! all before fields set to now values 96 ts b (:,:,:,:) = tsn (:,:,:,:)97 u b (:,:,:) = un (:,:,:)98 v b (:,:,:) = vn (:,:,:)99 ssh b (:,:) = sshn (:,:)100 e3t _b(:,:,:) = e3t_n(:,:,:)98 ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) 99 uu (:,:,:,Kbb) = uu (:,:,:,Kmm) 100 vv (:,:,:,Kbb) = vv (:,:,:,Kmm) 101 ssh (:,:,Kbb) = ssh (:,:,Kmm) 102 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 101 103 102 104 ! prepare writing restart … … 111 113 END SUBROUTINE isfcpl_init 112 114 ! 113 SUBROUTINE isfcpl_rst_write(kt )115 SUBROUTINE isfcpl_rst_write(kt, Kmm) 114 116 !!--------------------------------------------------------------------- 115 117 !! *** ROUTINE iscpl_rst_write *** … … 119 121 !!-------------------------- IN -------------------------------------- 120 122 INTEGER, INTENT(in) :: kt 123 INTEGER, INTENT(in) :: Kmm ! ocean time level index 121 124 !!---------------------------------------------------------------------- 122 125 ! … … 124 127 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios ) 125 128 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 126 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , e3t _n, ldxios = lwxios )127 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , e3u _n, ldxios = lwxios )128 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , e3v _n, ldxios = lwxios )129 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw _n, ldxios = lwxios )129 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , e3t(:,:,:,Kmm) , ldxios = lwxios ) 130 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , e3u(:,:,:,Kmm) , ldxios = lwxios ) 131 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , e3v(:,:,:,Kmm) , ldxios = lwxios ) 132 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm) , ldxios = lwxios ) 130 133 IF( lwxios ) CALL iom_swap( cxios_context ) 131 134 ! 132 135 END SUBROUTINE isfcpl_rst_write 133 136 134 SUBROUTINE isfcpl_ssh( )137 SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) 135 138 !!---------------------------------------------------------------------- 136 139 !! *** ROUTINE iscpl_ssh *** … … 142 145 !!---------------------------------------------------------------------- 143 146 !! 147 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 148 !!---------------------------------------------------------------------- 144 149 INTEGER :: ji, jj, jd, jk !! loop index 145 150 INTEGER :: jip1, jim1, jjp1, jjm1 … … 154 159 ! rude average of the closest neigbourgs (e1e2t not taking into account) 155 160 ! 156 zssh(:,:) = ssh n(:,:)161 zssh(:,:) = ssh(:,:,Kmm) 157 162 zssmask0(:,:) = zssmask_b(:,:) 158 163 ! … … 168 173 ! 169 174 IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN 170 ssh n(ji,jj)=( zssh(jip1,jj)*zssmask0(jip1,jj) &175 ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) & 171 176 & + zssh(jim1,jj)*zssmask0(jim1,jj) & 172 177 & + zssh(ji,jjp1)*zssmask0(ji,jjp1) & … … 177 182 END DO 178 183 ! 179 zssh(:,:) = ssh n(:,:)184 zssh(:,:) = ssh(:,:,Kmm) 180 185 zssmask0(:,:) = zssmask_b(:,:) 181 186 ! … … 184 189 END DO 185 190 ! 186 ! update ssh n187 ssh n(:,:) = zssh(:,:) * ssmask(:,:)188 ! 189 ssh b(:,:) = sshn(:,:)190 ! 191 IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',ssh n(:,:))191 ! update ssh(:,:,Kmm) 192 ssh(:,:,Kmm) = zssh(:,:) * ssmask(:,:) 193 ! 194 ssh(:,:,Kbb) = ssh(:,:,Kmm) 195 ! 196 IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',ssh(:,:,Kmm)) 192 197 ! 193 198 ! recompute the vertical scale factor, depth and water thickness 194 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh n (new wet cell)'199 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 195 200 IF(lwp) write(numout,*) '~~~~~~~~~~~' 196 201 DO jk = 1, jpk 197 e3t _n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) &202 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 198 203 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 199 204 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 200 205 END DO 201 e3t _b(:,:,:) = e3t_n(:,:,:)202 CALL dom_vvl_zgr( )206 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 207 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 203 208 ! 204 209 END SUBROUTINE isfcpl_ssh 205 210 206 SUBROUTINE isfcpl_tra( )211 SUBROUTINE isfcpl_tra(Kmm) 207 212 !!---------------------------------------------------------------------- 208 213 !! *** ROUTINE iscpl_tra *** … … 213 218 !! 214 219 !!---------------------------------------------------------------------- 220 INTEGER, INTENT(in) :: Kmm ! ocean time level index 221 !!---------------------------------------------------------------------- 215 222 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b 216 223 !REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before … … 237 244 !bugged : to be corrected (PM) 238 245 ! back up original t/s/mask 239 !tsb (:,:,:,:) = ts n(:,:,:,:)246 !tsb (:,:,:,:) = ts(:,:,:,:,Kmm) 240 247 ! 241 248 ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask … … 248 255 ! 249 256 ! !compute weight 250 ! zdzp1 = MAX(0._wp,pdepw_b(ji,jj,jk+1) - gdepw _n(ji,jj,jk+1))251 ! zdzm1 = MAX(0._wp,gdepw _n(ji,jj,jk) - pdepw_b(ji,jj,jk ))252 ! zdz = e3t _n(ji,jj,jk) - zdzp1 - zdzm1 ! if isf : e3t = gdepw_n(ji,jj,jk+1)- gdepw_n(ji,jj,jk)257 ! zdzp1 = MAX(0._wp,pdepw_b(ji,jj,jk+1) - gdepw(ji,jj,jk+1,Kmm)) 258 ! zdzm1 = MAX(0._wp,gdepw(ji,jj,jk ,Kmm) - pdepw_b(ji,jj,jk )) 259 ! zdz = e3t(ji,jj,jk,Kmm) - zdzp1 - zdzm1 ! if isf : e3t = gdepw(ji,jj,jk+1,Kmm)- gdepw(ji,jj,jk,Kmm) 253 260 ! 254 261 ! IF (zdz .LT. 0._wp) THEN … … 256 263 ! END IF 257 264 ! 258 ! ts n(ji,jj,jk,jp_tem) = ( zdzp1*tsb(ji,jj,jk+1,jp_tem) &259 ! & + zdz *ts b(ji,jj,jk ,jp_tem) &260 ! & + zdzm1*ts b(ji,jj,jk-1,jp_tem) )/e3t_n(ji,jj,jk)265 ! ts(ji,jj,jk,jp_tem,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_tem,Kbb) & 266 ! & + zdz *ts(ji,jj,jk ,jp_tem,Kbb) & 267 ! & + zdzm1*ts(ji,jj,jk-1,jp_tem,Kbb) )/e3t(ji,jj,jk,Kmm) 261 268 ! 262 ! ts n(ji,jj,jk,jp_sal) = ( zdzp1*tsb(ji,jj,jk+1,jp_sal) &263 ! & + zdz *ts b(ji,jj,jk ,jp_sal) &264 ! & + zdzm1*ts b(ji,jj,jk-1,jp_sal) )/e3t_n(ji,jj,jk)269 ! ts(ji,jj,jk,jp_sal,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_sal,Kbb) & 270 ! & + zdz *ts(ji,jj,jk ,jp_sal,Kbb) & 271 ! & + zdzm1*ts(ji,jj,jk-1,jp_sal,Kbb) )/e3t(ji,jj,jk,Kmm) 265 272 ! 266 273 ! END IF … … 270 277 ! END IF 271 278 272 zts0(:,:,:,:) = ts n(:,:,:,:)279 zts0(:,:,:,:) = ts(:,:,:,:,Kmm) 273 280 ztmask0(:,:,:) = ztmask_b(:,:,:) 274 281 ztmask1(:,:,:) = ztmask_b(:,:,:) … … 294 301 ! 295 302 ! horizontal basic extrapolation 296 ts n(ji,jj,jk,1)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) &303 ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) & 297 304 & + zts0(jim1,jj ,jk,1) * ztmask0(jim1,jj ,jk) & 298 305 & + zts0(ji ,jjp1,jk,1) * ztmask0(ji ,jjp1,jk) & 299 306 & + zts0(ji ,jjm1,jk,1) * ztmask0(ji ,jjm1,jk) ) / zsummsk 300 ts n(ji,jj,jk,2)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) &307 ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) & 301 308 & + zts0(jim1,jj ,jk,2) * ztmask0(jim1,jj ,jk) & 302 309 & + zts0(ji ,jjp1,jk,2) * ztmask0(ji ,jjp1,jk) & … … 316 323 zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1) 317 324 IF (zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN 318 ts n(ji,jj,jk,1)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) &325 ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) & 319 326 & + zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1)) / zsummsk 320 ts n(ji,jj,jk,2)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) &327 ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) & 321 328 & + zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1)) / zsummsk 322 329 ! … … 330 337 ! 331 338 ! update temperature and salinity and mask 332 zts0(:,:,:,:) = ts n(:,:,:,:)339 zts0(:,:,:,:) = ts(:,:,:,:,Kmm) 333 340 ztmask0(:,:,:) = ztmask1(:,:,:) 334 341 ! … … 337 344 END DO ! nn_drown 338 345 ! 339 ! mask new ts nfield340 ts n(:,:,:,jp_tem) = zts0(:,:,:,jp_tem) * tmask(:,:,:)341 ts n(:,:,:,jp_sal) = zts0(:,:,:,jp_sal) * tmask(:,:,:)346 ! mask new ts(:,:,:,:,Kmm) field 347 ts(:,:,:,jp_tem,Kmm) = zts0(:,:,:,jp_tem) * tmask(:,:,:) 348 ts(:,:,:,jp_sal,Kmm) = zts0(:,:,:,jp_sal) * tmask(:,:,:) 342 349 ! 343 350 ! sanity check … … 347 354 DO jj = 1,jpj 348 355 DO ji = 1,jpi 349 IF (tmask(ji,jj,jk) == 1._wp .AND. ts n(ji,jj,jk,2) == 0._wp) &356 IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) & 350 357 & CALL ctl_stop('STOP', 'failing to fill all new weet cell, & 351 358 & try increase nn_drown or activate XXXX & … … 357 364 END SUBROUTINE isfcpl_tra 358 365 359 SUBROUTINE isfcpl_vol( )366 SUBROUTINE isfcpl_vol(Kmm) 360 367 !!---------------------------------------------------------------------- 361 368 !! *** ROUTINE iscpl_vol *** … … 370 377 !!---------------------------------------------------------------------- 371 378 !! 379 INTEGER, INTENT(in) :: Kmm ! ocean time level index 380 !!---------------------------------------------------------------------- 372 381 INTEGER :: ji, jj, jk 373 382 INTEGER :: ikb, ikt … … 388 397 DO jj = 2, jpjm1 389 398 DO ji = 2, jpim1 390 zqvolb(ji,jj,jk) = ( e2u(ji,jj) * ze3u_b(ji,jj,jk) * u n(ji,jj,jk) - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * un(ji-1,jj ,jk) &391 & + e1v(ji,jj) * ze3v_b(ji,jj,jk) * v n(ji,jj,jk) - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vn(ji ,jj-1,jk) ) &399 zqvolb(ji,jj,jk) = ( e2u(ji,jj) * ze3u_b(ji,jj,jk) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & 400 & + e1v(ji,jj) * ze3v_b(ji,jj,jk) * vv(ji,jj,jk,Kmm) - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & 392 401 & * ztmask_b(ji,jj,jk) 393 402 END DO … … 397 406 ! properly mask velocity 398 407 ! (velocity are still mask with old mask at this stage) 399 u n(:,:,jk) = un(:,:,jk) * umask(:,:,jk)400 v n(:,:,jk) = vn(:,:,jk) * vmask(:,:,jk)408 uu(:,:,jk,Kmm) = uu(:,:,jk,Kmm) * umask(:,:,jk) 409 vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk) 401 410 ! compute volume flux divergence after coupling 402 411 DO jj = 2, jpjm1 403 412 DO ji = 2, jpim1 404 zqvoln(ji,jj,jk) = ( e2u(ji,jj) * e3u _n(ji,jj,jk) * un(ji,jj,jk) - e2u(ji-1,jj ) * e3u_n(ji-1,jj ,jk) * un(ji-1,jj ,jk) &405 & + e1v(ji,jj) * e3v _n(ji,jj,jk) * vn(ji,jj,jk) - e1v(ji ,jj-1) * e3v_n(ji ,jj-1,jk) * vn(ji ,jj-1,jk) ) &413 zqvoln(ji,jj,jk) = ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & 414 & + e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & 406 415 & * tmask(ji,jj,jk) 407 416 END DO … … 428 437 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. ) 429 438 ! 430 ! 3.0: set total correction (div, tr a, ssh)439 ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) 431 440 ! 432 441 ! 3.1: mask volume flux divergence correction 433 442 risfcpl_vol(:,:,:) = risfcpl_vol(:,:,:) * tmask(:,:,:) 434 443 ! 435 ! 3.2: get 3d tr aincrement to apply at the first time step436 ! temperature and salt content flux computed using local ts n444 ! 3.2: get 3d tr(:,:,:,:,Krhs) increment to apply at the first time step 445 ! temperature and salt content flux computed using local ts(:,:,:,:,Kmm) 437 446 ! (very simple advection scheme) 438 447 ! (>0 out) 439 risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts n(:,:,:,jp_tem)440 risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts n(:,:,:,jp_sal)448 risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_tem,Kmm) 449 risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_sal,Kmm) 441 450 ! 442 451 ! 3.3: ssh correction (for dynspg_ts) … … 448 457 END SUBROUTINE isfcpl_vol 449 458 450 SUBROUTINE isfcpl_cons( )459 SUBROUTINE isfcpl_cons(Kmm) 451 460 !!---------------------------------------------------------------------- 452 461 !! *** ROUTINE iscpl_cons *** … … 463 472 TYPE(isfcons), DIMENSION(:),ALLOCATABLE :: zisfpts ! list of point receiving a correction 464 473 ! 474 !!---------------------------------------------------------------------- 475 INTEGER, INTENT(in) :: Kmm ! ocean time level index 476 !!---------------------------------------------------------------------- 465 477 INTEGER :: ji , jj , jk , jproc ! loop index 466 478 INTEGER :: jip1 , jim1, jjp1, jjm1 ! dummy indices … … 513 525 514 526 ! volume diff 515 zdvol = e3t _n(ji,jj,jk) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)527 zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 516 528 517 529 ! heat diff 518 zdtem = ts n (ji,jj,jk,jp_tem) * e3t_n(ji,jj,jk) * tmask (ji,jj,jk) &530 zdtem = ts (ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 519 531 - zt_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 520 532 521 533 ! salt diff 522 zdsal = ts n(ji,jj,jk,jp_sal) * e3t_n(ji,jj,jk) * tmask (ji,jj,jk) &534 zdsal = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 523 535 - zs_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 524 536
Note: See TracChangeset
for help on using the changeset viewer.
