- Timestamp:
- 2020-09-29T12:41:06+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/r12377_ticket2386
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/ISF/isfcpl.F90 (modified) (23 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/r12377_ticket2386
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 8 9 9 # SETTE 10 ^/utils/CI/sette@ HEADsette10 ^/utils/CI/sette@13507 sette
-
- Property svn:externals
-
NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcpl.F90
r12511 r13540 15 15 USE isfutils, ONLY : debug 16 16 USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine 17 #if ! defined key_qco 17 18 USE domvvl , ONLY: dom_vvl_zgr ! vertical scale factor interpolation 18 USE domngb , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position 19 #else 20 USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation 21 #endif 22 USE domutl , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position 19 23 ! 20 24 USE oce ! ocean dynamics and tracers … … 43 47 !! * Substitutions 44 48 # include "do_loop_substitute.h90" 49 # include "domzgr_substitute.h90" 45 50 !!---------------------------------------------------------------------- 46 51 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 112 117 vv (:,:,:,Kbb) = vv (:,:,:,Kmm) 113 118 ssh (:,:,Kbb) = ssh (:,:,Kmm) 119 #if ! defined key_qco 114 120 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 115 121 #endif 116 122 ! prepare writing restart 117 123 IF( lwxios ) THEN … … 135 141 INTEGER, INTENT(in) :: Kmm ! ocean time level index 136 142 !!---------------------------------------------------------------------- 143 INTEGER :: jk ! loop index 144 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! e3t , e3u, e3v !!st patch to use substitution 145 !!---------------------------------------------------------------------- 146 ! 147 DO jk = 1, jpk 148 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 149 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 150 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 151 ! 152 zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm) 153 END DO 137 154 ! 138 155 IF( lwxios ) CALL iom_swap( cwxios_context ) 139 156 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios ) 140 157 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 141 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , e3t(:,:,:,Kmm), ldxios = lwxios )142 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , e3u(:,:,:,Kmm), ldxios = lwxios )143 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , e3v(:,:,:,Kmm), ldxios = lwxios )144 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm), ldxios = lwxios )158 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t , ldxios = lwxios ) 159 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u , ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v , ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 145 162 IF( lwxios ) CALL iom_swap( cxios_context ) 146 163 ! … … 166 183 !!---------------------------------------------------------------------- 167 184 ! 168 CALL iom_get( numror, jpdom_auto glo, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S185 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S 169 186 170 187 ! compute new ssh if we open a full water column … … 177 194 ! 178 195 zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) 179 DO_2D _00_00196 DO_2D( 0, 0, 0, 0 ) 180 197 jip1=ji+1; jim1=ji-1; 181 198 jjp1=jj+1; jjm1=jj-1; … … 195 212 zssmask0(:,:) = zssmask_b(:,:) 196 213 ! 197 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1. , zssmask0, 'T', 1.)214 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 198 215 ! 199 216 END DO … … 209 226 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 210 227 IF(lwp) write(numout,*) '~~~~~~~~~~~' 228 #if ! defined key_qco 211 229 DO jk = 1, jpk 212 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 213 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 214 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 230 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) 215 231 END DO 216 232 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 217 233 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 234 #else 235 CALL dom_qco_zgr(Kbb, Kmm, Kaa) 236 #endif 218 237 ! 219 238 END SUBROUTINE isfcpl_ssh … … 245 264 !!---------------------------------------------------------------------- 246 265 ! 247 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S248 !CALL iom_get( numror, jpdom_auto glo, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S249 !CALL iom_get( numror, jpdom_auto glo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)266 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S 267 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S 268 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl) 250 269 ! 251 270 ! … … 298 317 zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk); 299 318 ! 300 DO_2D _00_00319 DO_2D( 0, 0, 0, 0 ) 301 320 jip1=ji+1; jim1=ji-1; 302 321 jjp1=jj+1; jjm1=jj-1; … … 348 367 ztmask0(:,:,:) = ztmask1(:,:,:) 349 368 ! 350 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1. , zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.)369 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 351 370 ! 352 371 END DO ! nn_drown … … 359 378 ! ----------------------------------------------------------------------------------------- 360 379 ! case we open a cell but no neigbour cells available to get an estimate of T and S 361 DO_3D _11_11(1,jpk-1 )380 DO_3D( 1, 1, 1, 1, 1,jpk-1 ) 362 381 IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) & 363 382 & CALL ctl_stop('STOP', 'failing to fill all new weet cell, & … … 391 410 !!---------------------------------------------------------------------- 392 411 ! 393 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios )394 CALL iom_get( numror, jpdom_auto glo, 'e3u_n' , ze3u_b , ldxios = lrxios )395 CALL iom_get( numror, jpdom_auto glo, 'e3v_n' , ze3v_b , ldxios = lrxios )412 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) 413 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios ) 414 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios ) 396 415 ! 397 416 ! 1.0: compute horizontal volume flux divergence difference before-after coupling … … 399 418 DO jk = 1, jpk ! Horizontal slab 400 419 ! 1.1: get volume flux before coupling (>0 out) 401 DO_2D_00_00 402 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) & 403 & + 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) ) & 420 DO_2D( 0, 0, 0, 0 ) 421 zqvolb(ji,jj,jk) = & 422 & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) & 423 & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & 424 & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) & 425 & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & 404 426 & * ztmask_b(ji,jj,jk) 405 427 END_2D … … 411 433 vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk) 412 434 ! compute volume flux divergence after coupling 413 DO_2D_00_00 414 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) & 415 & + 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) ) & 435 DO_2D( 0, 0, 0, 0 ) 436 zqvoln(ji,jj,jk) = & 437 & ( e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * uu(ji ,jj ,jk,Kmm) & 438 & - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & 439 & + e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * vv(ji ,jj ,jk,Kmm) & 440 & - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & 416 441 & * tmask(ji,jj,jk) 417 442 END_2D … … 424 449 ! 2.0: include the contribution of the vertical velocity in the volume flux correction 425 450 ! 426 DO_2D _00_00451 DO_2D( 0, 0, 0, 0 ) 427 452 ! 428 453 ikt = mikt(ji,jj) … … 433 458 END_2D 434 459 ! 435 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. )460 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp ) 436 461 ! 437 462 ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) … … 495 520 496 521 ! get restart variable 497 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S498 CALL iom_get( numror, jpdom_auto glo, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios )499 CALL iom_get( numror, jpdom_auto glo, 'tn' , zt_b(:,:,:) , ldxios = lrxios )500 CALL iom_get( numror, jpdom_auto glo, 'sn' , zs_b(:,:,:) , ldxios = lrxios )522 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S 523 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios ) 524 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios ) 525 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios ) 501 526 502 527 ! compute run length … … 519 544 520 545 DO jk = 1,jpk-1 521 DO jj = nldj,nlej522 DO ji = nldi,nlei546 DO jj = Njs0,Nje0 547 DO ji = Nis0,Nie0 523 548 524 549 ! volume diff 525 zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 550 zdvol = e3t (ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 551 & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk) 526 552 527 553 ! heat diff … … 552 578 nisfl(:)=0 553 579 DO jk = 1,jpk-1 554 DO jj = nldj,nlej555 DO ji = nldi,nlei580 DO jj = Njs0,Nje0 581 DO ji = Nis0,Nie0 556 582 jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; 557 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 583 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 584 nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 585 ENDIF 558 586 ENDDO 559 587 ENDDO … … 572 600 jisf = 0 573 601 DO jk = 1,jpk-1 574 DO jj = nldj,nlej575 DO ji = nldi,nlei602 DO jj = Njs0,Nje0 603 DO ji = Nis0,Nie0 576 604 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 577 605 … … 602 630 ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN 603 631 ! spread correction amoung neigbourg wet cells (vertical direction) 604 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1. , 0)632 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) 605 633 ELSE 606 634 ! need to find where to put correction in later on 607 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1. , 1)635 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) 608 636 END IF 609 637 END IF … … 665 693 ! 666 694 ! add lbclnk 667 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1. , risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., &668 & risfcpl_cons_vol(:,:,:) , 'T', 1. )695 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 696 & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) 669 697 ! 670 698 ! ssh correction (for dynspg_ts)
Note: See TracChangeset
for help on using the changeset viewer.
