- Timestamp:
- 2020-11-10T12:57:08+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_12905_xios_ancil
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/ISF/isfcpl.F90 (modified) (23 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_12905_xios_ancil
- 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@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/ISF/isfcpl.F90
r13016 r13766 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 ! … … 167 184 ! 168 185 IF(lrxios) CALL iom_swap( TRIM(crxios_context) ) 169 CALL iom_get( numror, jpdom_auto glo, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S186 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S 170 187 IF(lrxios) CALL iom_swap( TRIM(cxios_context) ) 171 188 … … 179 196 ! 180 197 zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) 181 DO_2D _00_00198 DO_2D( 0, 0, 0, 0 ) 182 199 jip1=ji+1; jim1=ji-1; 183 200 jjp1=jj+1; jjm1=jj-1; … … 197 214 zssmask0(:,:) = zssmask_b(:,:) 198 215 ! 199 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1. , zssmask0, 'T', 1.)216 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 200 217 ! 201 218 END DO … … 211 228 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 212 229 IF(lwp) write(numout,*) '~~~~~~~~~~~' 230 #if ! defined key_qco 213 231 DO jk = 1, jpk 214 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 215 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 216 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 232 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) 217 233 END DO 218 234 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 219 235 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 236 #else 237 CALL dom_qco_zgr(Kbb, Kmm, Kaa) 238 #endif 220 239 ! 221 240 END SUBROUTINE isfcpl_ssh … … 248 267 ! 249 268 IF(lrxios) CALL iom_swap( TRIM(crxios_context) ) 250 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S251 !CALL iom_get( numror, jpdom_auto glo, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S252 !CALL iom_get( numror, jpdom_auto glo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)269 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S 270 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S 271 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl) 253 272 IF(lrxios) CALL iom_swap( TRIM(cxios_context) ) 254 273 ! … … 302 321 zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk); 303 322 ! 304 DO_2D _00_00323 DO_2D( 0, 0, 0, 0 ) 305 324 jip1=ji+1; jim1=ji-1; 306 325 jjp1=jj+1; jjm1=jj-1; … … 352 371 ztmask0(:,:,:) = ztmask1(:,:,:) 353 372 ! 354 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1. , zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.)373 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 355 374 ! 356 375 END DO ! nn_drown … … 363 382 ! ----------------------------------------------------------------------------------------- 364 383 ! case we open a cell but no neigbour cells available to get an estimate of T and S 365 DO_3D _11_11(1,jpk-1 )384 DO_3D( 1, 1, 1, 1, 1,jpk-1 ) 366 385 IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) & 367 386 & CALL ctl_stop('STOP', 'failing to fill all new weet cell, & … … 396 415 ! 397 416 IF(lrxios) CALL iom_swap( TRIM(crxios_context) ) 398 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios )399 CALL iom_get( numror, jpdom_auto glo, 'e3u_n' , ze3u_b , ldxios = lrxios )400 CALL iom_get( numror, jpdom_auto glo, 'e3v_n' , ze3v_b , ldxios = lrxios )417 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) 418 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios ) 419 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios ) 401 420 IF(lrxios) CALL iom_swap( TRIM(cxios_context) ) 402 421 ! … … 405 424 DO jk = 1, jpk ! Horizontal slab 406 425 ! 1.1: get volume flux before coupling (>0 out) 407 DO_2D_00_00 408 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) & 409 & + 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) ) & 426 DO_2D( 0, 0, 0, 0 ) 427 zqvolb(ji,jj,jk) = & 428 & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) & 429 & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & 430 & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) & 431 & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & 410 432 & * ztmask_b(ji,jj,jk) 411 433 END_2D … … 417 439 vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk) 418 440 ! compute volume flux divergence after coupling 419 DO_2D_00_00 420 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) & 421 & + 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) ) & 441 DO_2D( 0, 0, 0, 0 ) 442 zqvoln(ji,jj,jk) = & 443 & ( e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * uu(ji ,jj ,jk,Kmm) & 444 & - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & 445 & + e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * vv(ji ,jj ,jk,Kmm) & 446 & - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & 422 447 & * tmask(ji,jj,jk) 423 448 END_2D … … 430 455 ! 2.0: include the contribution of the vertical velocity in the volume flux correction 431 456 ! 432 DO_2D _00_00457 DO_2D( 0, 0, 0, 0 ) 433 458 ! 434 459 ikt = mikt(ji,jj) … … 439 464 END_2D 440 465 ! 441 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. )466 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp ) 442 467 ! 443 468 ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) … … 502 527 ! get restart variable 503 528 IF(lrxios) CALL iom_swap( TRIM(crxios_context) ) 504 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S505 CALL iom_get( numror, jpdom_auto glo, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios )506 CALL iom_get( numror, jpdom_auto glo, 'tn' , zt_b(:,:,:) , ldxios = lrxios )507 CALL iom_get( numror, jpdom_auto glo, 'sn' , zs_b(:,:,:) , ldxios = lrxios )529 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S 530 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios ) 531 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios ) 532 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios ) 508 533 IF(lrxios) CALL iom_swap( TRIM(cxios_context) ) 509 534 … … 527 552 528 553 DO jk = 1,jpk-1 529 DO jj = nldj,nlej530 DO ji = nldi,nlei554 DO jj = Njs0,Nje0 555 DO ji = Nis0,Nie0 531 556 532 557 ! volume diff 533 zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 558 zdvol = e3t (ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 559 & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk) 534 560 535 561 ! heat diff … … 560 586 nisfl(:)=0 561 587 DO jk = 1,jpk-1 562 DO jj = nldj,nlej563 DO ji = nldi,nlei588 DO jj = Njs0,Nje0 589 DO ji = Nis0,Nie0 564 590 jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; 565 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) 591 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 592 nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 593 ENDIF 566 594 ENDDO 567 595 ENDDO … … 580 608 jisf = 0 581 609 DO jk = 1,jpk-1 582 DO jj = nldj,nlej583 DO ji = nldi,nlei610 DO jj = Njs0,Nje0 611 DO ji = Nis0,Nie0 584 612 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 585 613 … … 610 638 ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN 611 639 ! spread correction amoung neigbourg wet cells (vertical direction) 612 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1. , 0)640 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) 613 641 ELSE 614 642 ! need to find where to put correction in later on 615 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1. , 1)643 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) 616 644 END IF 617 645 END IF … … 673 701 ! 674 702 ! add lbclnk 675 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1. , risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., &676 & risfcpl_cons_vol(:,:,:) , 'T', 1. )703 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 704 & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) 677 705 ! 678 706 ! ssh correction (for dynspg_ts)
Note: See TracChangeset
for help on using the changeset viewer.
