From 5d88f7cffa578e98576ef91273991899e6a07360 Mon Sep 17 00:00:00 2001 From: Joseph Olson Date: Fri, 31 Jul 2020 16:10:17 +0000 Subject: [PATCH 01/45] Updates and bug fix for MYNN surface layer scheme --- physics/module_MYNNSFC_wrapper.F90 | 26 +- physics/module_sf_mynn.F90 | 707 ++++++++++++++++++----------- 2 files changed, 454 insertions(+), 279 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 496db7580..7cc64bbcf 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -5,12 +5,16 @@ MODULE mynnsfc_wrapper USE module_sf_mynn + !Global variables: + INTEGER, PARAMETER :: psi_opt = 0 !0: MYNN + !1: GFS + contains - subroutine mynnsfc_wrapper_init () + subroutine mynnsfc_wrapper_init() ! initialize tables for psih and psim (stable and unstable) - CALL PSI_INIT + CALL PSI_INIT(psi_opt) end subroutine mynnsfc_wrapper_init @@ -100,10 +104,10 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & spp_pbl = 0, & - & isftcflx = 0, & - & iz0tlnd = 0, & + INTEGER, PARAMETER :: & + & spp_pbl = 0, & + & isftcflx = 0, & !control: 0 + & iz0tlnd = 0, & !control: 0 & isfflx = 1 integer, intent(in) :: ivegsrc @@ -166,7 +170,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & lh, wstar !LOCAL real, dimension(im) :: & - & hfx, znt, ts, psim, psih, & + & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & & cpm, qgh, qfx @@ -199,14 +203,11 @@ SUBROUTINE mynnsfc_wrapper_run( & xland(i)=2.0 endif qgh(i)=0.0 + mavail(i)=1.0 !snowh(i)=snowd(i)*800. !mm -> m !znt_lnd(i)=znt_lnd(i)*0.01 !cm -> m !znt_ocn(i)=znt_ocn(i)*0.01 !cm -> m !znt_ice(i)=znt_ice(i)*0.01 !cm -> m - ! DH* do the following line only if wet(i)? - ts(i)=tskin_ocn(i)/exner(i,1) !theta - ! *DH - mavail(i)=1.0 !???? cpm(i)=cp enddo @@ -251,7 +252,8 @@ SUBROUTINE mynnsfc_wrapper_run( & CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & EP1=ep_1,EP2=ep_2,KARMAN=karman, & - ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,iz0tlnd=iz0tlnd, & + ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm, & + iz0tlnd=iz0tlnd,psi_opt=psi_opt, & & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) & z0pert=z0pert,ztpert=ztpert, & !intent(in) & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 94b118521..ebbc3dcf9 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -7,7 +7,7 @@ MODULE module_sf_mynn !------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES +!Modifications implemented by Joseph Olson NOAA/GSL !The following overviews the current state of this scheme:: ! ! BOTH LAND AND WATER: @@ -129,11 +129,13 @@ MODULE module_sf_mynn !! and Grachev et al (2000) for unstable conditions and the form !! from Cheng and Brutsaert (2005) for stable conditions. - SUBROUTINE mynn_sf_init_driver(allowed_to_read) + SUBROUTINE mynn_sf_init_driver(allowed_to_read,psi_opt) LOGICAL, INTENT(in) :: allowed_to_read + INTEGER, INTENT(IN) :: psi_opt - CALL psi_init + !CALL psi_init + CALL psi_init(psi_opt) END SUBROUTINE mynn_sf_init_driver @@ -146,7 +148,7 @@ SUBROUTINE SFCLAY_mynn( & PSFCPA,PBLH,MAVAIL,XLAND,DX, & !in CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in - ISFFLX,isftcflx,lsm,iz0tlnd, & !in + ISFFLX,isftcflx,lsm,iz0tlnd,psi_opt, & !in & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) @@ -285,7 +287,7 @@ SUBROUTINE SFCLAY_mynn( & !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl + INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -297,7 +299,7 @@ SUBROUTINE SFCLAY_mynn( & !=================================== ! 3D VARIABLES !=================================== - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + REAL, DIMENSION( ims:ime, kms:kme ) , & INTENT(IN ) :: dz8w, & QV3D, & P3D, & @@ -306,24 +308,24 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D, & th3d,pi3d - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, & + REAL, DIMENSION( ims:ime, kms:kme), OPTIONAL, & INTENT(IN) :: pattern_spp_pbl !=================================== ! 2D VARIABLES !=================================== - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(INOUT) :: HFLX,HFX, & QFLX,QFX, & LH, & @@ -369,7 +371,7 @@ SUBROUTINE SFCLAY_mynn( & !ADDITIONAL OUTPUT !JOE-begin - REAL, DIMENSION( ims:ime, jms:jme ) :: qstar + REAL, DIMENSION( ims:ime ) :: qstar !JOE-end !=================================== ! 1D LOCAL ARRAYS @@ -384,7 +386,7 @@ SUBROUTINE SFCLAY_mynn( & REAL, DIMENSION( its:ite ) :: rstoch1D - INTEGER :: I,J,K,itf,jtf,ktf + INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- IF (debug_code >= 1) THEN @@ -397,100 +399,91 @@ SUBROUTINE SFCLAY_mynn( & ENDIF itf=ite !MIN0(ite,ide-1) - jtf=jte !MIN0(jte,jde-1) ktf=kte !MIN0(kte,kde-1) - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,kts,j) - dz2w1d(I) = dz8w(i,kts+1,j) - U1D(i) =U3D(i,kts,j) - V1D(i) =V3D(i,kts,j) - !2nd model level winds - for diags with high-res grids - U1D2(i) =U3D(i,kts+1,j) - V1D2(i) =V3D(i,kts+1,j) - QV1D(i)=QV3D(i,kts,j) - QC1D(i)=QC3D(i,kts,j) - P1D(i) =P3D(i,kts,j) - T1D(i) =T3D(i,kts,j) - if (spp_pbl==1) then - rstoch1D(i)=pattern_spp_pbl(i,kts,j) - else - rstoch1D(i)=0.0 - endif - ENDDO - - IF (itimestep==1 .AND. iter==1) THEN - DO i=its,ite - !Everything here is used before calculated - UST_OCN(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - MOL(i,j)=0. ! Tstar - QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j)) - QSFC_OCN(i)=QSFC(i,j) - QSFC_LND(i)=QSFC(i,j) - QSFC_ICE(i)=QSFC(i,j) - qstar(i,j)=0.0 - QFX(i,j)=0. - HFX(i,j)=0. - QFLX(i,j)=0. - HFLX(i,j)=0. - ENDDO - ELSE - IF (LSM == 3) THEN - DO i=its,ite - QSFC_LND(i)=QSFC_RUC(i) - ENDDO - ENDIF - ENDIF + DO i=its,ite + dz8w1d(I) = dz8w(i,kts) + dz2w1d(I) = dz8w(i,kts+1) + U1D(i) =U3D(i,kts) + V1D(i) =V3D(i,kts) + !2nd model level winds - for diags with high-res grids + U1D2(i) =U3D(i,kts+1) + V1D2(i) =V3D(i,kts+1) + QV1D(i)=QV3D(i,kts) + QC1D(i)=QC3D(i,kts) + P1D(i) =P3D(i,kts) + T1D(i) =T3D(i,kts) + if (spp_pbl==1) then + rstoch1D(i)=pattern_spp_pbl(i,kts) + else + rstoch1D(i)=0.0 + endif + ENDDO - CALL SFCLAY1D_mynn( & - J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & - U1D2,V1D2,dz2w1d, & - PSFCPA(ims,j),PBLH(ims,j),MAVAIL(ims,j), & - XLAND(ims,j),DX(ims,j), & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & - ISFFLX,isftcflx,iz0tlnd, & - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) - itimestep,iter, & - wet, dry, icy, & !intent(in) - tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) - tsurf_ocn, tsurf_lnd, tsurf_ice, & !intent(in) - qsfc_ocn, qsfc_lnd, qsfc_ice, & !intent(in) - snowh_ocn, snowh_lnd, snowh_ice, & !intent(in) - ZNT_ocn, ZNT_lnd, ZNT_ice, & !intent(inout) - UST_ocn, UST_lnd, UST_ice, & !intent(inout) - cm_ocn, cm_lnd, cm_ice, & !intent(inout) - ch_ocn, ch_lnd, ch_ice, & !intent(inout) - rb_ocn, rb_lnd, rb_ice, & !intent(inout) - stress_ocn, stress_lnd, stress_ice, & !intent(inout) - fm_ocn, fm_lnd, fm_ice, & !intent(inout) - fh_ocn, fh_lnd, fh_ice, & !intent(inout) - fm10_ocn, fm10_lnd, fm10_ice, & !intent(inout) - fh2_ocn, fh2_lnd, fh2_ice, & - HFLX_ocn, HFLX_lnd, HFLX_ice, & - QFLX_ocn, QFLX_lnd, QFLX_ice, & - ch(ims,j),CHS(ims,j),CHS2(ims,j),CQS2(ims,j), & - CPM(ims,j), & - ZNT(ims,j),USTM(ims,j),ZOL(ims,j), & - MOL(ims,j),RMOL(ims,j), & - PSIM(ims,j),PSIH(ims,j), & - HFLX(ims,j),HFX(ims,j),QFLX(ims,j),QFX(ims,j), & - LH(ims,j),FLHC(ims,j),FLQC(ims,j), & - QGH(ims,j),QSFC(ims,j), & - U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j),Q2(ims,j),& - GZ1OZ0(ims,j),WSPD(ims,j),wstar(ims,j), & - spp_pbl,rstoch1D, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) + IF (itimestep==1 .AND. iter==1) THEN + DO i=its,ite + !Everything here is used before calculated + UST_OCN(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + MOL(i)=0.0 + QSFC(i)=QV3D(i,kts)/(1.+QV3D(i,kts)) + QSFC_OCN(i)=QSFC(i) + QSFC_LND(i)=QSFC(i) + QSFC_ICE(i)=QSFC(i) + qstar(i)=0.0 + QFX(i)=0. + HFX(i)=0. + QFLX(i)=0. + HFLX(i)=0. + ENDDO + ELSE + IF (LSM == 3) THEN + DO i=its,ite + QSFC_LND(i)=QSFC_RUC(i) + ENDDO + ENDIF + ENDIF - ENDDO + CALL SFCLAY1D_mynn( & + J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & + U1D2,V1D2,dz2w1d, & + PSFCPA,PBLH,MAVAIL,XLAND,DX, & + CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & + EP1,EP2,KARMAN, & + ISFFLX,isftcflx,iz0tlnd,psi_opt, & + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) + itimestep,iter, & + wet, dry, icy, & !intent(in) + tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) + tsurf_ocn, tsurf_lnd, tsurf_ice, & !intent(in) + qsfc_ocn, qsfc_lnd, qsfc_ice, & !intent(in) + snowh_ocn, snowh_lnd, snowh_ice, & !intent(in) + ZNT_ocn, ZNT_lnd, ZNT_ice, & !intent(inout) + UST_ocn, UST_lnd, UST_ice, & !intent(inout) + cm_ocn, cm_lnd, cm_ice, & !intent(inout) + ch_ocn, ch_lnd, ch_ice, & !intent(inout) + rb_ocn, rb_lnd, rb_ice, & !intent(inout) + stress_ocn, stress_lnd, stress_ice, & !intent(inout) + fm_ocn, fm_lnd, fm_ice, & !intent(inout) + fh_ocn, fh_lnd, fh_ice, & !intent(inout) + fm10_ocn, fm10_lnd, fm10_ice, & !intent(inout) + fh2_ocn, fh2_lnd, fh2_ice, & + HFLX_ocn, HFLX_lnd, HFLX_ice, & + QFLX_ocn, QFLX_lnd, QFLX_ice, & + ch,CHS,CHS2,CQS2,CPM, & + ZNT,USTM,ZOL,MOL,RMOL, & + PSIM,PSIH, & + HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & + QGH,QSFC,U10,V10,TH2,T2,Q2, & + GZ1OZ0,WSPD,wstar, & + spp_pbl,rstoch1D, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte & + ) END SUBROUTINE SFCLAY_MYNN @@ -505,10 +498,10 @@ SUBROUTINE SFCLAY1D_mynn( & PSFCPA,PBLH,MAVAIL,XLAND,DX, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & - ISFFLX,isftcflx,iz0tlnd, & - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) + ISFFLX,isftcflx,iz0tlnd,psi_opt, & + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) itimestep,iter, & wet, dry, icy, & !intent(in) tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) @@ -560,7 +553,7 @@ SUBROUTINE SFCLAY1D_mynn( & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, INTENT(IN) :: spp_pbl + INTEGER, INTENT(IN) :: spp_pbl, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -676,7 +669,7 @@ SUBROUTINE SFCLAY1D_mynn( & REAL :: PL,E1,TABS REAL :: WSPD_lnd, WSPD_ice, WSPD_ocn - REAL :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0 + REAL :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT REAL :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 REAL :: FLUXC,VSGD REAL :: restar,VISC,DQG,OLDUST,OLDTST @@ -891,8 +884,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_ocn(I)=MAX(rb_ocn(I),-2.0) rb_ocn(I)=MIN(rb_ocn(I), 2.0) ELSE - rb_ocn(I)=MAX(rb_ocn(I),-50.0) - rb_ocn(I)=MIN(rb_ocn(I), 50.0) + rb_ocn(I)=MAX(rb_ocn(I),-10.0) + rb_ocn(I)=MIN(rb_ocn(I), 10.0) ENDIF ENDIF ! end water point @@ -931,8 +924,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_lnd(I)=MAX(rb_lnd(I),-2.0) rb_lnd(I)=MIN(rb_lnd(I), 2.0) ELSE - rb_lnd(I)=MAX(rb_lnd(I),-50.0) - rb_lnd(I)=MIN(rb_lnd(I), 50.0) + rb_lnd(I)=MAX(rb_lnd(I),-10.0) + rb_lnd(I)=MIN(rb_lnd(I), 10.0) ENDIF ENDIF ! end land point @@ -965,8 +958,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_ice(I)=MAX(rb_ice(I),-2.0) rb_ice(I)=MIN(rb_ice(I), 2.0) ELSE - rb_ice(I)=MAX(rb_ice(I),-50.0) - rb_ice(I)=MIN(rb_ice(I), 50.0) + rb_ice(I)=MAX(rb_ice(I),-10.0) + rb_ice(I)=MIN(rb_ice(I), 10.0) ENDIF ENDIF ! end ice point @@ -1121,11 +1114,11 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF GZ1OZ0_ocn(I)= LOG((ZA(I)+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ1OZt_ocn(I)= LOG((ZA(I)+ZT_ocn(i))/ZT_ocn(i)) + GZ1OZt_ocn(I)= LOG((ZA(I)+ZNTstoch_ocn(i))/ZT_ocn(i)) GZ2OZ0_ocn(I)= LOG((2.0+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ2OZt_ocn(I)= LOG((2.0+ZT_ocn(i))/ZT_ocn(i)) + GZ2OZt_ocn(I)= LOG((2.0+ZNTstoch_ocn(i))/ZT_ocn(i)) GZ10OZ0_ocn(I)=LOG((10.+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ10OZt_ocn(I)=LOG((10.+ZT_ocn(i))/ZT_ocn(i)) + GZ10OZt_ocn(I)=LOG((10.+ZNTstoch_ocn(i))/ZT_ocn(i)) zratio_ocn(i)=ZNTstoch_ocn(I)/ZT_ocn(I) !need estimate for Li et al. ENDIF !end water point @@ -1178,11 +1171,11 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ1OZt_lnd(I)= LOG((ZA(I)+ZT_lnd(i))/ZT_lnd(i)) + GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) GZ2OZ0_lnd(I)= LOG((2.0+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ2OZt_lnd(I)= LOG((2.0+ZT_lnd(i))/ZT_lnd(i)) + GZ2OZt_lnd(I)= LOG((2.0+ZNTstoch_lnd(i))/ZT_lnd(i)) GZ10OZ0_lnd(I)=LOG((10.+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ10OZt_lnd(I)=LOG((10.+ZT_lnd(i))/ZT_lnd(i)) + GZ10OZt_lnd(I)=LOG((10.+ZNTstoch_lnd(i))/ZT_lnd(i)) zratio_lnd(i)=ZNTstoch_lnd(I)/ZT_lnd(I) !need estimate for Li et al. ENDIF !end land point @@ -1207,11 +1200,11 @@ SUBROUTINE SFCLAY1D_mynn( & CALL Andreas_2002(ZNTstoch_ice(i),visc,ust_ice(i),ZT_ice(i),ZQ_ice(i)) GZ1OZ0_ice(I)= LOG((ZA(I)+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ1OZt_ice(I)= LOG((ZA(I)+ZT_ice(i))/ZT_ice(i)) + GZ1OZt_ice(I)= LOG((ZA(I)+ZNTstoch_ice(i))/ZT_ice(i)) GZ2OZ0_ice(I)= LOG((2.0+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ2OZt_ice(I)= LOG((2.0+ZT_ice(i))/ZT_ice(i)) + GZ2OZt_ice(I)= LOG((2.0+ZNTstoch_ice(i))/ZT_ice(i)) GZ10OZ0_ice(I)=LOG((10.+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ10OZt_ice(I)=LOG((10.+ZT_ice(i))/ZT_ice(i)) + GZ10OZt_ice(I)=LOG((10.+ZNTstoch_ice(i))/ZT_ice(i)) zratio_ice(i)=ZNTstoch_ice(I)/ZT_ice(I) !need estimate for Li et al. ENDIF !end ice point @@ -1234,13 +1227,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_ocn(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),20.) IF (debug_code >= 1) THEN IF (ZNTstoch_ocn(i) < 1E-8 .OR. Zt_ocn(i) < 1E-10) THEN @@ -1252,11 +1242,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I)) + !zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),zt_ocn(I),GZ1OZ0_ocn(I),GZ1OZt_ocn(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_ocn(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ocn(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ocn(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ocn(I))/za(I) ! (10+z0)/L @@ -1269,11 +1263,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ocn(I),ZNTstoch_ocn(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) ! or use tables - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1298,13 +1292,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_ocn(i) < 1E-8 .OR. Zt_ocn(i) < 1E-10) THEN @@ -1316,11 +1307,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),zt_ocn(I),GZ1OZ0_ocn(I),GZ1OZt_ocn(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_ocn(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ocn(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ocn(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ocn(I))/za(I) ! (10+z0)/L @@ -1332,11 +1327,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ocn(I),ZNTstoch_ocn(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1365,13 +1360,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_lnd(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),50.) IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1383,11 +1375,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I)) + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_lnd(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_lnd(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_lnd(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_lnd(I))/za(I) ! (10+z0)/L @@ -1399,11 +1395,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_lnd(I),ZNTstoch_lnd(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1428,13 +1424,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1446,11 +1439,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_lnd(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_lnd(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_lnd(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_lnd(I))/za(I) ! (10+z0)/L @@ -1461,11 +1458,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_lnd(I),ZNTstoch_lnd(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1494,13 +1491,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_ice(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),50.) IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN @@ -1512,11 +1506,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I)) + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_ice(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ice(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ice(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ice(I))/za(I) ! (10+z0)/L @@ -1528,11 +1526,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ice(I),ZNTstoch_ice(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1557,13 +1555,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN @@ -1575,11 +1570,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_ice(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ice(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ice(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ice(I))/za(I) ! (10+z0)/L @@ -1590,11 +1589,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ice(I),ZNTstoch_ice(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1644,7 +1643,7 @@ SUBROUTINE SFCLAY1D_mynn( & !NON-AVERAGED: !UST_lnd(I)=KARMAN*WSPD(I)/PSIX_lnd(I) !From Tilden Meyers: - !IF (rb_lnd(I) .GE 0.0) THEN + !IF (rb_lnd(I) .GE. 0.0) THEN ! ust_lnd(i)=WSPD_lnd*0.1/(1.0 + 10.0*rb_lnd(I)) !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird @@ -2546,6 +2545,10 @@ SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) END SUBROUTINE GFS_z0_lnd !-------------------------------------------------------------------- ! Taken from the GFS (sfc_diff.f) for comparison +! This formulation comes from Zheng et al. (2012, JGR), which is a +! modified form of the Zilitinkevich thermal roughness length but it adds +! the dependence on vegetation fraction. +! SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) REAL, INTENT(OUT) :: ztmax @@ -3227,18 +3230,21 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) END SUBROUTINE Li_etal_2010 !------------------------------------------------------------------- - REAL function zolri(ri,za,z0,zt,zol1) + REAL function zolri(ri,za,z0,zt,zol1,psi_opt) ! This iterative algorithm was taken from the revised surface layer ! scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and ! summarized in Jimenez et al. (2012, MWR). This function was adapted - ! to input the thermal roughness length, zt, (as well as z0) because - ! zt is necessary input for the Dyer-Hicks functions used in MYNN. + ! to input the thermal roughness length, zt, (as well as z0) and use initial + ! estimate of z/L. IMPLICIT NONE REAL, INTENT(IN) :: ri,za,z0,zt,zol1 + INTEGER, INTENT(IN) :: psi_opt REAL :: x1,x2,fx1,fx2 INTEGER :: n + INTEGER, PARAMETER :: nmax = 20 + !REAL, DIMENSION(nmax):: zLhux if (ri.lt.0.)then x1=zol1 - 0.02 !-5. @@ -3248,40 +3254,38 @@ REAL function zolri(ri,za,z0,zt,zol1) x2=zol1 + 0.02 !5. endif - n=0 - fx1=zolri2(x1,ri,za,z0,zt) - fx2=zolri2(x2,ri,za,z0,zt) - Do While (abs(x1 - x2) > 0.01 .and. n < 5) + n=1 + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + + Do While (abs(x1 - x2) > 0.01 .and. n < nmax) if(abs(fx2).lt.abs(fx1))then x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,za,z0,zt) + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) zolri=x1 else x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,za,z0,zt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) zolri=x2 endif n=n+1 !print*," n=",n," x1=",x1," x2=",x2 + !zLhux(n)=zolri enddo - if (n==5 .and. abs(x1 - x2) >= 0.01) then - !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri - !Tests results: fails convergence ~ 0.07 % of the time - !set approximate values: - if (ri.lt.0.)then - zolri=ri*5. - else - zolri=ri*8. - endif - !else - ! print*,"iter OK, n=",n," Ri=",ri," z/L=",zolri + if (n==nmax .and. abs(x1 - x2) >= 0.01) then + !if convergence fails, use approximate values: + CALL Li_etal_2010(zolri, ri, za/z0, z0/zt) + !zLhux(n)=zolri + !print*,"iter FAIL, n=",n," Ri=",ri," z0=",z0 + else + !print*,"SUCCESS,n=",n," Ri=",ri," z0=",z0 endif return end function !------------------------------------------------------------------- - REAL function zolri2(zol2,ri2,za,z0,zt) + REAL function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! INPUT: ================================= ! zol2 - estimated z/L @@ -3290,59 +3294,150 @@ REAL function zolri2(zol2,ri2,za,z0,zt) ! z0 - aerodynamic roughness length ! zt - thermal roughness length ! OUTPUT: ================================ - ! zolri2 - updated estimate of z/L + ! zolri2 - delta Ri IMPLICIT NONE + INTEGER, INTENT(IN) :: psi_opt REAL, INTENT(IN) :: ri2,za,z0,zt REAL, INTENT(INOUT) :: zol2 - REAL :: zol20,zol3,psim1,psih1,psix2,psit2 + REAL :: zol20,zol3,psim1,psih1,psix2,psit2,zolt if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 zol20=zol2*z0/za ! z0/L zol3=zol2+zol20 ! (z+z0)/L + zolt=zol2*zt/za ! zt/L if (ri2.lt.0) then - !CALL PSI_DyerHicks(psim1,psih1,zol3,zt,z0,za) - psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - !psix2=log((za+z0)/z0)-psim1 - !psit2=log((za+zt)/zt)-psih1 + !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=MAX(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=MAX(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) else - !CALL PSI_DyerHicks(psim1,psih1,zol2,zt,z0,za) - !CALL PSI_CB2005(psim1,psih1,zol3,zol20) - psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - !psix2=log((za+z0)/z0)-psim1 - !psit2=log((za+zt)/zt)-psih1 + !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=MAX(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=MAX(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) endif zolri2=zol2*psit2/psix2**2 - ri2 + !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 return end function !==================================================================== - SUBROUTINE psi_init - INTEGER :: N - REAL :: zolf + REAL function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) - DO N=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) + ! This iterative algorithm to compute z/L from bulk-Ri - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - ENDDO + IMPLICIT NONE + REAL, INTENT(IN) :: ri,za,z0,zt,logz0,logzt + INTEGER, INTENT(IN) :: psi_opt + REAL, INTENT(INOUT) :: zol1 + REAL :: zol20,zol3,zolt,zolold + INTEGER :: n + INTEGER, PARAMETER :: nmax = 20 + REAL, DIMENSION(nmax):: zLhux + REAL :: psit2,psix2 + + !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri + if (zol1*ri .lt. 0.) THEN + !print*,"begin: WRONG QUADRANTS: z/L=",zol1," ri=",ri + zol1=0. + endif + + if (ri .lt. 0.) then + zolold=-99999. + zolrib=-66666. + else + zolold=99999. + zolrib=66666. + endif + n=1 + + DO While (abs(zolold - zolrib) > 0.01 .and. n < nmax) + + if(n==1)then + zolold=zol1 + else + zolold=zolrib + endif + zol20=zolold*z0/za ! z0/L + zol3=zolold+zol20 ! (z+z0)/L + zolt=zolold*zt/za ! zt/L + !print*,"z0/L=",zol20," (z+z0)/L=",zol3," zt/L=",zolt + if (ri.lt.0) then + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=MAX(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) + else + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=MAX(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) + endif + !print*,"n=",n," psit2=",psit2," psix2=",psix2 + zolrib=ri*psix2**2/psit2 + zLhux(n)=zolrib + n=n+1 + enddo + + if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then + !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri + !if convergence fails, use approximate values: + CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) + zLhux(n)=zolrib + !print*,"FAILED, n=",n," Ri=",ri," z0=",z0 + !print*,"z/L=",zLhux(1:nmax) + else + !if(zolrib*ri .lt. 0.) THEN + ! !print*,"end: WRONG QUADRANTS: z/L=",zolrib," ri=",ri + ! !CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) + !endif + !print*,"SUCCESS,n=",n," Ri=",ri," z0=",z0 + endif + + return + end function +!==================================================================== + + SUBROUTINE psi_init(psi_opt) + + INTEGER :: N,psi_opt + REAL :: zolf + + if (psi_opt == 0) then + DO N=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + ENDDO + else + DO N=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full_gfs(zolf) + psih_stab(n)=psih_stable_full_gfs(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full_gfs(zolf) + psih_unstab(n)=psih_unstable_full_gfs(zolf) + ENDDO + endif END SUBROUTINE psi_init ! ================================================================== -! ... integrated similarity functions ... -! +! ... integrated similarity functions from MYNN... +! REAL function psim_stable_full(zolf) REAL :: zolf @@ -3392,11 +3487,73 @@ REAL function psih_unstable_full(zolf) return end function + +! ================================================================== +! ... integrated similarity functions from GFS... +! + REAL function psim_stable_full_gfs(zolf) + REAL :: zolf + REAL, PARAMETER :: alpha4 = 20. + REAL :: aa + + aa = sqrt(1. + alpha4 * zolf) + psim_stable_full_gfs = -1.*aa + log(aa + 1.) + + return + end function + + REAL function psih_stable_full_gfs(zolf) + REAL :: zolf + REAL, PARAMETER :: alpha4 = 20. + REAL :: bb + + bb = sqrt(1. + alpha4 * zolf) + psih_stable_full_gfs = -1.*bb + log(bb + 1.) + + return + end function + + REAL function psim_unstable_full_gfs(zolf) + REAL :: zolf + REAL :: hl1,tem1 + REAL, PARAMETER :: a0=-3.975, a1=12.32, & + b1=-7.755, b2=6.041 + + if (zolf .ge. -0.5) then + hl1 = zolf + psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 + end if + + return + end function + + REAL function psih_unstable_full_gfs(zolf) + REAL :: zolf + REAL :: hl1,tem1 + REAL, PARAMETER :: a0p=-7.941, a1p=24.75, & + b1p=-8.705, b2p=7.899 + + if (zolf .ge. -0.5) then + hl1 = zolf + psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 + end if + + return + end function + !================================================================= -! look-up table functions +! look-up table functions - or, if beyond -10 < z/L < 10, recalculate !================================================================= - REAL function psim_stable(zolf) - integer :: nzol + REAL function psim_stable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(zolf*100.) @@ -3404,14 +3561,18 @@ REAL function psim_stable(zolf) if(nzol+1 .le. 1000)then psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) else - psim_stable = psim_stable_full(zolf) + if (psi_opt == 0) then + psim_stable = psim_stable_full(zolf) + else + psim_stable = psim_stable_full_gfs(zolf) + endif endif return end function - REAL function psih_stable(zolf) - integer :: nzol + REAL function psih_stable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(zolf*100.) @@ -3419,14 +3580,18 @@ REAL function psih_stable(zolf) if(nzol+1 .le. 1000)then psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) else - psih_stable = psih_stable_full(zolf) + if (psi_opt == 0) then + psih_stable = psih_stable_full(zolf) + else + psih_stable = psih_stable_full_gfs(zolf) + endif endif return end function - REAL function psim_unstable(zolf) - integer :: nzol + REAL function psim_unstable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(-zolf*100.) @@ -3434,14 +3599,18 @@ REAL function psim_unstable(zolf) if(nzol+1 .le. 1000)then psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) else - psim_unstable = psim_unstable_full(zolf) + if (psi_opt == 0) then + psim_unstable = psim_unstable_full(zolf) + else + psim_unstable = psim_unstable_full_gfs(zolf) + endif endif return end function - REAL function psih_unstable(zolf) - integer :: nzol + REAL function psih_unstable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(-zolf*100.) @@ -3449,7 +3618,11 @@ REAL function psih_unstable(zolf) if(nzol+1 .le. 1000)then psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) else - psih_unstable = psih_unstable_full(zolf) + if (psi_opt == 0) then + psih_unstable = psih_unstable_full(zolf) + else + psih_unstable = psih_unstable_full_gfs(zolf) + endif endif return From 5943288b2298112dbdea47bba9af1385fbb660c5 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 31 Jul 2020 17:29:24 +0000 Subject: [PATCH 02/45] Changes for flexible number of soil levels. --- physics/gcycle.F90 | 36 ++++--- physics/sfcsub.F | 255 +++++++++++---------------------------------- 2 files changed, 86 insertions(+), 205 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index bc1bb032c..c37d39d10 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -58,9 +58,9 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) ABSFCS (Model%nx*Model%ny), & ALFFC1 (Model%nx*Model%ny*2), & ALBFC1 (Model%nx*Model%ny*4), & - SMCFC1 (Model%nx*Model%ny*Model%lsoil), & - STCFC1 (Model%nx*Model%ny*Model%lsoil), & - SLCFC1 (Model%nx*Model%ny*Model%lsoil) + SMCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)), & + STCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)), & + SLCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)) character(len=6) :: tile_num_ch real(kind=kind_phys), parameter :: pifac=180.0/pi @@ -134,10 +134,16 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) ALBFC1 (len + npts*2) = Sfcprop(nb)%alnsf (ix) ALBFC1 (len + npts*3) = Sfcprop(nb)%alnwf (ix) - do ls = 1,Model%lsoil - SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) - STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) - SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + do ls = 1,max(Model%lsoil,Model%lsoil_lsm) + if (Model%lsoil == Model%lsoil_lsm) then + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + else + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smois (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%tslb (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%sh2o (ix,ls) + endif enddo IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN @@ -171,7 +177,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) rewind (Model%nlunit) endif #endif - CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & + CALL SFCCYCLE (9998, npts, max(Model%lsoil,Model%lsoil_lsm), SIG1T, Model%fhcyc, & Model%idate(4), Model%idate(2), & Model%idate(3), Model%idate(1), & Model%phour, RLA, RLO, SLMASK, & @@ -235,10 +241,16 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%alvwf (ix) = ALBFC1 (len + npts ) Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) - do ls = 1,Model%lsoil - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + do ls = 1,max(Model%lsoil,Model%lsoil_lsm) + if(Model%lsoil == Model%lsoil_lsm) then + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + else + Sfcprop(nb)%smois (ix,ls) = SMCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%tslb (ix,ls) = STCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%sh2o (ix,ls) = SLCFC1 (len + (ls-1)*npts) + endif if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (len + (ls-1)*npts) enddo ENDDO !-----END BLOCK SIZE LOOP------------------------------ diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 6296e7856..a78ac650f 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -3,7 +3,7 @@ !>\defgroup mod_sfcsub GFS sfcsub Module -!!\ingroup Noah_LSM +!!\ingroup LSMs !> @{ !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). @@ -299,7 +299,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx (for noah lsm) +!clu [-1l/+1l] relax tsfsmx parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, & tsfjmx=273.16,tsfjmn=173.0) @@ -384,8 +384,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(snwmin=5.0,snwmax=100.) real (kind=kind_io8), parameter :: ten=10.0, one=1.0 ! -! coeeficients of blending forecast and interpolated clim +! coeficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) +!tgs -- important ! 1.0 = use of forecast ! 0.0 = replace with interpolated analysis ! @@ -395,10 +396,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! --------------------------------------------------------- ! surface temperature forecast analysis ! surface temperature forecast forecast (over sea ice) -! albedo analysis analysis +! albedo forecast/analysis analysis ! sea-ice analysis analysis -! snow analysis forecast (over sea ice) -! roughness analysis forecast +! snow forecast/analysis forecast (over sea ice) +! roughness forecast/analysis forecast ! plant resistance analysis analysis ! soil wetness (layer) weighted average analysis ! soil temperature forecast analysis @@ -416,7 +417,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! max snow albedo analysis analysis ! slope type analysis analysis ! liquid soil wetness analysis-weighted analysis -! actual snow depth analysis-weighted analysis +! actual snow depth forecast/analysis-weighted analysis ! ! note: if analysis file is not given, then time interpolated climatology ! is used. if analyiss file is given, it will be used as far as the @@ -533,9 +534,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! rec. 1 label ! rec. 2 date record ! rec. 3 tsf -! rec. 4 soilm(two layers) ----> 4 layers +! rec. 4 soilm(lsoil) ! rec. 5 snow -! rec. 6 soilt(two layers) ----> 4 layers +! rec. 6 soilt(lsoil) ! rec. 7 tg3 ! rec. 8 zor ! rec. 9 cv @@ -560,7 +561,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! rec. 25 tprcp ! rec. 26 srflag ! rec. 27 swd -! rec. 28 slc (4 layers) +! rec. 28 slc (lsoil) ! rec. 29 vmn ! rec. 30 vmx ! rec. 31 slp @@ -1234,50 +1235,27 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get soil temp and moisture (after all the qcs are completed) ! + !-- soil moisture if(fnsmcc(1:8).eq.' ') then call getsmc(wetclm,len,lsoil,smcclm,me) endif - call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + do k=1,lsoil + call qcmxmn('smc ',smcclm(1,k),sliclm,snoclm,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo + !-- soil temperature if(fnstcc(1:8).eq.' ') then call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif - call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + do k=1,lsoil + call qcmxmn('stc ',stcclm(1,k),sliclm,snoclm,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo + call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1335,17 +1313,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisclm',aisclm,sliclm,snoclm,len) call monitr('snoclm',snoclm,sliclm,snoclm,len) call monitr('scvclm',scvclm,sliclm,snoclm,len) - call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) - call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) - call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) - call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) -!clu [+4l] add smcclm(3:4) and stcclm(3:4) - if(lsoil.gt.2) then - call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) - call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) - call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) - call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) - endif + do k=1,lsoil + call monitr('smcclm1',smcclm(1,k),sliclm,snoclm,len) + call monitr('stcclm1',stcclm(1,k),sliclm,snoclm,len) + enddo call monitr('tg3clm',tg3clm,sliclm,snoclm,len) call monitr('zorclm',zorclm,sliclm,snoclm,len) ! if (gaus) then @@ -1637,47 +1608,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then call getsmc(wetanl,len,lsoil,smcanl,me) endif - call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + !-- soil moisture + do k=1,lsoil + call qcmxmn('smca ',smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo + !-- soil temperature if(fnstca(1:8).eq.' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif - call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + do k=1,lsoil + call qcmxmn('stca ',stcanl(1,1),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1723,17 +1670,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisanl',aisanl,slianl,snoanl,len) call monitr('snoanl',snoanl,slianl,snoanl,len) call monitr('scvanl',scvanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - endif + do k=1,lsoil + call monitr('smcanl',smcanl(1,k),slianl,snoanl,len) + call monitr('stcanl',stcanl(1,k),slianl,snoanl,len) + enddo call monitr('tg3anl',tg3anl,slianl,snoanl,len) call monitr('zoranl',zoranl,slianl,snoanl,len) ! if (gaus) then @@ -1902,44 +1842,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, & sicjmx,sicjmn,sicsmx,sicsmn,epssic, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, +!-- soil moisture forecast + do k=1,lsoil + call qcmxmn('smcf ',smcfcs(1,k),slifcs,snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, + enddo +!-- soil temperature forecast + do k=1,lsoil + call qcmxmn('stcf ',stcfcs(1,k),slifcs,snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1985,17 +1901,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albfcs',albfcs,slifcs,snofcs,len) call monitr('aisfcs',aisfcs,slifcs,snofcs,len) call monitr('snofcs',snofcs,slifcs,snofcs,len) - call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) - call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) - call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) - call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) -!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if(lsoil.gt.2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) - endif + do k=1,lsoil + call monitr('smcfcs',smcfcs(1,k),slifcs,snofcs,len) + call monitr('stcfcs',stcfcs(1,k),slifcs,snofcs,len) + enddo call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) call monitr('zorfcs',zorfcs,slifcs,snofcs,len) ! if (gaus) then @@ -2138,44 +2047,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, ! & rla,rlo,len,kqcm,percrit,lgchek,me) ! endif - call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + do k=1,lsoil + call qcmxmn('stcm ',stcanl(1,k),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + enddo + do k=1,lsoil + call qcmxmn('smcm ',smcanl(1,k),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo kqcm=1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -2258,19 +2141,12 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albanl',albanl,slianl,snoanl,len) call monitr('aisanl',aisanl,slianl,snoanl,len) call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + do k=1,lsoil + call monitr('smcanl',smcanl(1,k),slianl,snoanl,len) + call monitr('stcanl',stcanl(1,k),slianl,snoanl,len) + enddo call monitr('tg3anl',tg3anl,slianl,snoanl,len) call monitr('zoranl',zoranl,slianl,snoanl,len) - endif ! if (gaus) then call monitr('cvaanl',cvanl ,slianl,snoanl,len) call monitr('cvbanl',cvbanl,slianl,snoanl,len) @@ -2344,17 +2220,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) call monitr('aisdif',aisfcs,slianl,snoanl,len) call monitr('snodif',snofcs,slianl,snoanl,len) - call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) -!clu [+4l] add smcfcs(3:4) and stc(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) - endif + do k=1,lsoil + call monitr('smcanl',smcfcs(1,k),slianl,snoanl,len) + call monitr('stcanl',stcfcs(1,k),slianl,snoanl,len) + enddo call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) ! if (gaus) then From 2235fb5ec61cb1af47879acd3db6c665c57604af Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 10 Aug 2020 10:00:54 -0600 Subject: [PATCH 03/45] Add tracer sanitizer --- physics/tracer_sanitizer.F90 | 113 ++++++++++++++++++++++++++++++++ physics/tracer_sanitizer.meta | 117 ++++++++++++++++++++++++++++++++++ 2 files changed, 230 insertions(+) create mode 100644 physics/tracer_sanitizer.F90 create mode 100644 physics/tracer_sanitizer.meta diff --git a/physics/tracer_sanitizer.F90 b/physics/tracer_sanitizer.F90 new file mode 100644 index 000000000..ee699b837 --- /dev/null +++ b/physics/tracer_sanitizer.F90 @@ -0,0 +1,113 @@ +module tracer_sanitizer + + use machine, only : kind_phys + + implicit none + + private + + public :: tracer_sanitizer_init, tracer_sanitizer_run, tracer_sanitizer_finalize + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: qvmin = 1.0E-6_kind_phys + +contains + + subroutine tracer_sanitizer_init() + end subroutine tracer_sanitizer_init + +!> \section arg_table_tracer_sanitizer_run Argument Table +!! \htmlinclude tracer_sanitizer_run.html +!! + subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & + ntlnc, ntinc, ntrnc, ntsnc, ntgnc, errmsg, errflg) + + ! Interface variables + integer, intent(in ) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & + ntlnc, ntinc, ntrnc, ntsnc, ntgnc + real(kind=kind_phys), intent(inout) :: tracers(:,:,:) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Water vapor specific humidity + if (ntqv>0) then + where (tracers(:,:,ntqv)0) then + where (tracers(:,:,ntcw)0) then + where (tracers(:,:,ntlnc)==zero) + tracers(:,:,ntlnc)=zero + end where + end if + end if + + ! Ice water + if (ntiw>0) then + where (tracers(:,:,ntiw)0) then + where (tracers(:,:,ntinc)==zero) + tracers(:,:,ntinc)=zero + end where + end if + end if + + ! Rain water + if (ntrw>0) then + where (tracers(:,:,ntrw)0) then + where (tracers(:,:,ntrnc)==zero) + tracers(:,:,ntrnc)=zero + end where + end if + end if + + ! Snow + if (ntsw>0) then + where (tracers(:,:,ntsw)0) then + where (tracers(:,:,ntsnc)==zero) + tracers(:,:,ntsnc)=zero + end where + end if + end if + + ! Graupel + if (ntgl>0) then + where (tracers(:,:,ntgl)0) then + where (tracers(:,:,ntgnc)==zero) + tracers(:,:,ntgnc)=zero + end where + end if + end if + + end subroutine tracer_sanitizer_run + + subroutine tracer_sanitizer_finalize() + end subroutine tracer_sanitizer_finalize + +end module tracer_sanitizer \ No newline at end of file diff --git a/physics/tracer_sanitizer.meta b/physics/tracer_sanitizer.meta new file mode 100644 index 000000000..582823fdb --- /dev/null +++ b/physics/tracer_sanitizer.meta @@ -0,0 +1,117 @@ +[ccpp-arg-table] + name = tracer_sanitizer_run + type = scheme +[tracers] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[ntqv] + standard_name = index_for_water_vapor + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntlnc] + standard_name = index_for_liquid_cloud_number_concentration + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntinc] + standard_name = index_for_ice_cloud_number_concentration + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgnc] + standard_name = index_for_graupel_number_concentration + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 408d078d6bfa0d34b180ac321de1685d5e49c771 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 11 Aug 2020 07:20:16 -0600 Subject: [PATCH 04/45] Bug fix in physics/tracer_sanitizer.F90 --- physics/tracer_sanitizer.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/tracer_sanitizer.F90 b/physics/tracer_sanitizer.F90 index ee699b837..668cf6edd 100644 --- a/physics/tracer_sanitizer.F90 +++ b/physics/tracer_sanitizer.F90 @@ -59,7 +59,7 @@ subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & tracers(:,:,ntiw)=zero end where ! Adjust second moments - if (ntlnc>0) then + if (ntinc>0) then where (tracers(:,:,ntinc)==zero) tracers(:,:,ntinc)=zero end where @@ -72,7 +72,7 @@ subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & tracers(:,:,ntrw)=zero end where ! Adjust second moments - if (ntlnc>0) then + if (ntrnc>0) then where (tracers(:,:,ntrnc)==zero) tracers(:,:,ntrnc)=zero end where @@ -85,7 +85,7 @@ subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & tracers(:,:,ntsw)=zero end where ! Adjust second moments - if (ntlnc>0) then + if (ntsnc>0) then where (tracers(:,:,ntsnc)==zero) tracers(:,:,ntsnc)=zero end where @@ -98,7 +98,7 @@ subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & tracers(:,:,ntgl)=zero end where ! Adjust second moments - if (ntlnc>0) then + if (ntgnc>0) then where (tracers(:,:,ntgnc)==zero) tracers(:,:,ntgnc)=zero end where From 1c7b52ab85ecaf370e56f0b5f3e7e4a351c4170f Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 13 Aug 2020 13:41:21 -0600 Subject: [PATCH 05/45] - Physics changes made for/during HFIP 2020 - All changes in GF (set c0 = 0.02 for mid-clouds, changes water-ice transition temperature to what was used in FIM) --- physics/cu_gf_deep.F90 | 30 ++++++++++++++++++++---------- physics/cu_gf_driver.F90 | 4 ++-- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 4afad80d1..a07523342 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -338,6 +338,7 @@ subroutine cu_gf_deep_run( & integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers + real(kind=kind_phys) :: c0 ! HCB ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -383,6 +384,14 @@ subroutine cu_gf_deep_run( & ! sas ! lambau=0. ! pgcon=-.55 +! +!---------------------------------------------------- ! HCB +! Set cloud water to rain water conversion rate (c0) + c0=0.004 + if(imid.eq.1)then + c0=0.002 + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ztexec(:) = 0. zqexec(:) = 0. @@ -937,14 +946,14 @@ subroutine cu_gf_deep_run( & if(imid.eq.1)then call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) else call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) @@ -1266,14 +1275,14 @@ subroutine cu_gf_deep_run( & ! if(imid.eq.1)then ! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & ! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & ! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & ! 1,itf,ktf, & ! its,ite, kts,kte) ! else ! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & ! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & ! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & ! 1,itf,ktf, & ! its,ite, kts,kte) @@ -3865,7 +3874,7 @@ end subroutine cup_output_ens_3d !>\ingroup cu_gf_deep_group subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & - q,gamma_cup,zu,qes_cup,k22,qe_cup, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & zqexec,ccn,rho,c1d,t, & up_massentr,up_massdetr,psum,psumh, & itest,itf,ktf, & @@ -3904,6 +3913,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 + real(kind=kind_phys), intent (in ) :: & ! HCB + c0 ! ! input and output ! @@ -3944,7 +3955,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer :: start_level(its:ite) real(kind=kind_phys) :: & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & - c0,dz,berryc0,q1,berryc + dz,berryc0,q1,berryc real(kind=kind_phys) :: & denom, c0t real(kind=kind_phys), dimension (kts:kte) :: & @@ -3952,7 +3963,6 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! prop_b(kts:kte)=0 iall=0 - c0=.002 clwdet=50. bdsp=bdispm ! @@ -3999,7 +4009,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & enddo do 100 i=its,itf - c0=.004 + !c0=.004 HCB tuning if(ierr(i).eq.0)then ! below lfc, but maybe above lcl @@ -4031,8 +4041,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! do k=kbcon(i)+1,ktop(i) - c0=.004 - if(t(i,k).lt.270.)c0=.002 + !c0=.004 HCB tuning + !if(t(i,k).lt.270.)c0=.002 HCB tuning if(t(i,k) > 273.16) then c0t = c0 else diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 5c43709d1..aa3ca977e 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -190,10 +190,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & real(kind=kind_phys), dimension (im) :: hfx,qfx real(kind=kind_phys) tem,tem1,tf,tcr,tcrf - parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) - !parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim, HCB tuning ! initialize ccpp error handling variables errmsg = '' errflg = 0 From 427ce1edf760d80d24b8e11a154da76db16f70a9 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 27 Aug 2020 19:43:25 +0000 Subject: [PATCH 06/45] The first draft of change to mode RUC LSM soil variables initialization to the ;sm_ruc_init. Several issues: 1. soil and vegetation types needed for initialization are not assigned yet. Therefore, some parts of the code that use soil types is turned off. 2. There seems to ne inconsistency of land=true/false with the Noah smc, stc, slc variables. At this stage the limited verison of initialization code causes a crash in Thompson MP. --- physics/module_sf_ruclsm.F90 | 135 +++++++++--------- physics/sfc_drv_ruc.F90 | 242 ++++++++++++++++++++++---------- physics/sfc_drv_ruc.meta | 264 +++++++++++++++++++++++++++++++++++ 3 files changed, 492 insertions(+), 149 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 7345f2667..e02e1edb0 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7022,8 +7022,8 @@ END SUBROUTINE SOILVEGIN !> This subroutine computes liquid and forezen soil moisture from the !! total soil moisture, and also computes soil moisture availability in !! the top soil layer. - SUBROUTINE RUCLSMINIT( debug_print, landmask, & - nzs, isltyp, ivgtyp, xice, mavail, & + SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & + nzs, isltyp, ivgtyp, mavail, & sh2o, smfr3d, tslb, smois, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -7035,35 +7035,33 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - + LOGICAL, INTENT(IN ) :: frac_grid + LOGICAL, DIMENSION( ims:ime), INTENT(IN ) :: land, icy INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(IN) :: TSLB, & - SMOIS - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN) :: LANDMASK + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(IN) :: TSLB, & + SMOIS - INTEGER, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ISLTYP,IVGTYP + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ISLTYP,IVGTYP - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(INOUT) :: SMFR3D, & - SH2O + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(OUT) :: SMFR3D, & + SH2O - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: XICE,MAVAIL + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: MAVAIL - REAL, DIMENSION ( 1:nzs ) :: SOILIQW + !-- local + REAL, DIMENSION ( 1:nzs ) :: SOILIQW -! - INTEGER :: I,J,L,itf,jtf - REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + INTEGER :: I,J,L,itf,jtf + REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7077,9 +7075,6 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & errflag = 0 DO j = jts,jtf DO i = its,itf - ! land-only version - IF ( LANDMASK( i,j ) .NE. 1 ) CYCLE - ! IF ( ISLTYP( i,j ) .LT. 0 ) THEN errflag = 1 print *, & @@ -7096,65 +7091,61 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & DO J=jts,jtf DO I=its,itf - ! land-only version - IF ( LANDMASK( i,j ) .NE. 1 ) CYCLE - -!--- Computation of volumetric content of ice in soil -!--- and initialize MAVAIL - if(ISLTYP(I,J) > 0) then - DQM = MAXSMC (ISLTYP(I,J)) - & - DRYSMC (ISLTYP(I,J)) - REF = REFSMC (ISLTYP(I,J)) - PSIS = - SATPSI (ISLTYP(I,J)) - QMIN = DRYSMC (ISLTYP(I,J)) - BCLH = BB (ISLTYP(I,J)) - endif + ! in Zobler classification isltyp=0 for water. Statsgo classification + ! has isltyp=14 for water + if (isltyp(i,j) == 0) isltyp(i,j)=14 + + if(land(i) ) then + !--- Computation of volumetric content of ice in soil + !--- and initialize MAVAIL + DQM = MAXSMC (ISLTYP(I,J)) - & + DRYSMC (ISLTYP(I,J)) + REF = REFSMC (ISLTYP(I,J)) + PSIS = - SATPSI (ISLTYP(I,J)) + QMIN = DRYSMC (ISLTYP(I,J)) + BCLH = BB (ISLTYP(I,J)) + + mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) -! in Zobler classification isltyp=0 for water. Statsgo classification -! has isltyp=14 for water - if (isltyp(i,j) == 0) isltyp(i,j)=14 + DO L=1,NZS + !-- for land points initialize soil ice + tln=log(TSLB(i,l,j)/273.15) + + if(tln.lt.0.) then + soiliqw(l)=(dqm+qmin)*(XLMELT* & + (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & + **(-1./bclh) + !**(-1./bclh)-qmin + soiliqw(l)=max(0.,soiliqw(l)) + soiliqw(l)=min(soiliqw(l),smois(i,l,j)) + sh2o(i,l,j)=soiliqw(l) + smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW + + else + smfr3d(i,l,j)=0. + sh2o(i,l,j)=smois(i,l,j) + endif + ENDDO - IF(xice(i,j).gt.0.) THEN -!-- for ice + elseif(icy(i) .and. .not. frac_grid ) then + !-- ice DO L=1,NZS smfr3d(i,l,j)=1. sh2o(i,l,j)=0. mavail(i,j) = 1. ENDDO - ELSE - if(isltyp(i,j).ne.14 ) then -!-- land - mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) - DO L=1,NZS -!-- for land points initialize soil ice - tln=log(TSLB(i,l,j)/273.15) - - if(tln.lt.0.) then - soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & - **(-1./bclh) -! **(-1./bclh)-qmin - soiliqw(l)=max(0.,soiliqw(l)) - soiliqw(l)=min(soiliqw(l),smois(i,l,j)) - sh2o(i,l,j)=soiliqw(l) - smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW - - else - smfr3d(i,l,j)=0. - sh2o(i,l,j)=smois(i,l,j) - endif - ENDDO + endif ! land - else + !else !-- for water ISLTYP=14 - DO L=1,NZS - smfr3d(i,l,j)=0. - sh2o(i,l,j)=1. - mavail(i,j) = 1. - ENDDO - endif - ENDIF + ! DO L=1,NZS + ! smfr3d(i,l,j)=0. + ! sh2o(i,l,j)=1. + ! mavail(i,j) = 1. + ! ENDDO + !endif + !ENDIF ENDDO ENDDO diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 65935ef1c..db1ad00b4 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -23,22 +23,118 @@ module lsm_ruc !! \section arg_table_lsm_ruc_init Argument Table !! \htmlinclude lsm_ruc_init.html !! - subroutine lsm_ruc_init (me, isot, ivegsrc, nlunit, & - & errmsg, errflg) + subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & + flag_restart, flag_init, & + im, lsoil_ruc, lsoil, kice, nlev, & ! in + lsm_ruc, lsm, & ! in + soiltyp, vegtype, frac_grid, land, icy, & ! in + fice, tsfc_lnd, tsfc_wat, tice, & + tg3, smc, slc, stc, & ! in + smcref2, smcwlt2, & ! inout + sh2o, smfrkeep, tslb, smois, wetness, & ! out + tsice, errmsg, errflg) implicit none +! --- in + integer, intent(in) :: me, master, isot, ivegsrc, nlunit + logical, intent(in) :: flag_restart + logical, intent(in) :: flag_init + logical, intent(in) :: frac_grid + integer, intent(in) :: im + integer, intent(in) :: lsoil_ruc + integer, intent(in) :: lsoil + integer, intent(in) :: kice + integer, intent(in) :: nlev + integer, intent(in) :: lsm_ruc, lsm + integer,dimension(im),intent(inout) :: soiltyp, vegtype + + logical, dimension(im), intent(in) :: land, icy + + real (kind=kind_phys), dimension(im), intent(in ) :: fice + real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_lnd + real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_wat + real (kind=kind_phys), dimension(im), intent(in ) :: tice + real (kind=kind_phys), dimension(im), intent(in) :: tg3 + + real (kind=kind_phys), dimension(im,lsoil), intent(in) :: smc,slc,stc + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: wetness + real (kind=kind_phys), dimension(im), intent(inout) :: smcref2, smcwlt2 + +! --- out + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(out) :: sh2o, smfrkeep + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(out) :: tslb, smois + real (kind=kind_phys), dimension(im,kice), intent(out) :: tsice - integer, intent(in) :: me, isot, ivegsrc, nlunit character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg +! --- local + integer :: ipr, i, k + logical :: debug_print + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + ipr = 10 + debug_print = .true. + +!> - Call rucinit() to initialize soil/ice/water variables + + if ( debug_print) then + write (0,*) 'RUC LSM initialization' + write (0,*) 'lsoil_ruc, lsoil',lsoil_ruc, lsoil + write (0,*) 'noah soil temp',stc(:,1) + write (0,*) 'noah soil mois',smc(:,1) + write (0,*) 'noah mois(ipr)',ipr,smc(ipr,:) + write (0,*) 'soiltyp=',soiltyp(:) + write (0,*) 'vegtype=',vegtype(:) + write (0,*) 'fice=',fice(:) + write (0,*) 'tice=',tice(:) + write (0,*) 'tsfc_lnd=',tsfc_lnd(:) + write (0,*) 'tsfc_wat=',tsfc_wat(:) + write (0,*) 'tg3=',tg3(:) + write (0,*) 'land=',land(:) + write (0,*) 'icy=',icy(:) + write (0,*) 'flag_init =',flag_init + write (0,*) 'flag_restart =',flag_restart + endif + !--- initialize soil vegetation call set_soilveg_ruc(me, isot, ivegsrc, nlunit) + if( .not. flag_restart) then + call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, isot, ivegsrc, nlunit, & ! in + lsm_ruc, lsm, & ! in + frac_grid, land, icy, & ! in + soiltyp, vegtype, fice, & ! in + tsfc_lnd, tsfc_wat, tice, tg3, & ! in + smc, slc, stc, & ! in + smcref2, smcwlt2, & ! inout + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) + + do i = 1, im ! i - horizontal loop + do k = 1, min(kice,lsoil_ruc) + ! - at initial time set sea ice T (tsice) + ! equal to TSLB, initialized from the Noah STC variable + tsice (i,k) = tslb(i,k) + enddo + enddo ! i + + endif ! flag_restart +!-- end of initialization + + if ( debug_print) then + write (0,*) 'ruc soil tslb',tslb(:,1) + write (0,*) 'ruc soil tsice',tsice(:,1) + write (0,*) 'ruc soil smois',smois(:,1) + write (0,*) 'ruc wetness',wetness(:) + endif + end subroutine lsm_ruc_init !! \section arg_table_lsm_ruc_finalize Argument Table @@ -303,25 +399,9 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'flag_restart =',flag_restart endif -!> - Call rucinit() at the first time step and the first interation -!! for RUC initialization,then overwrite Noah soil fields -!! with initialized RUC soil fields for output. if(flag_init .and. iter==1) then - if (debug_print) write (0,'(a,i0,a,l)') 'RUC LSM initialization, kdt = ', kdt, ', flag_restart = ', flag_restart - - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - isot, soiltyp, vegtype, fice, & ! in - land, tskin, tskin_wat, tg3, & ! in - smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout - lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out - me, master, errmsg, errflg) - xlai = 0. - endif ! flag_init=.true.,iter=1 -!-- end of initialization ims = 1 its = 1 @@ -692,7 +772,7 @@ subroutine lsm_ruc_run & ! inputs z0(i,j) = zorl(i)/100. znt(i,j) = zorl(i)/100. - if(debug_print) then + !if(debug_print) then if(me==0 .and. i==ipr) then write (0,*)'before RUC smsoil = ',smsoil(i,:,j), i,j write (0,*)'stsoil = ',stsoil(i,:,j), i,j @@ -788,7 +868,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) write (0,*)'rdlai2d =',rdlai2d endif - endif + !endif !> - Call RUC LSM lsmruc(). call lsmruc( delt, flag_init, flag_restart, kdt, iter, nsoil, & @@ -825,7 +905,9 @@ subroutine lsm_ruc_run & ! inputs & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) - if(debug_print) then + !if(debug_print) then + if(me==0.and.i==ipr) then + write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j write (0,*)'after sneqv(i,j) =',i,j,sneqv(i,j) write (0,*)'after snowh(i,j) =',i,j,snowh(i,j) write (0,*)'after sncovr(i,j) =',i,j,sncovr(i,j) @@ -860,6 +942,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) write (0,*)'after snomlt(i,j) =',i,j,snomlt(i,j) endif + !endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -871,16 +954,6 @@ subroutine lsm_ruc_run & ! inputs !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom !!\n \a snoh - phase-change heat flux from snowmelt (w m-2) ! - if(debug_print) then - !if(me==0.and.i==ipr) then - write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j - write (0,*)'stsoil = ',stsoil(i,:,j), i,j - write (0,*)'soilt = ',soilt(i,j), i,j - write (0,*)'wet = ',wet(i,j), i,j - write (0,*)'soilt1 = ',soilt1(i,j), i,j - write (0,*)'rhosnfr = ',rhosnfr(i,j), i,j - !endif - endif ! Interstitial evap(i) = qfx(i,j) / rho(i) ! kinematic @@ -1035,14 +1108,16 @@ end subroutine lsm_ruc_run !>\ingroup lsm_ruc_group !! This subroutine contains RUC LSM initialization. - subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in - isot, soiltyp, vegtype, fice, & ! in - land, tsurf, tsurf_wat, & ! in - tg3, smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout - lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, & ! out - wetness, me, master, errmsg, errflg) + subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, isot, ivegsrc, nlunit, & ! in + lsm_ruc, lsm, & ! in + frac_grid, land, icy, & ! in + soiltyp, vegtype, fice, & ! in + tskin_lnd, tskin_wat, tice, tg3, & ! !in + smc, slc, stc, & ! in + smcref2, smcwlt2, & ! inout + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) implicit none @@ -1050,11 +1125,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, intent(in ) :: lsm integer, intent(in ) :: lsm_ruc integer, intent(in ) :: isot + integer, intent(in ) :: ivegsrc, nlunit integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil - logical, dimension(im), intent(in ) :: land - real (kind=kind_phys), dimension(im), intent(in ) :: tsurf, tsurf_wat + logical, intent(in ) :: frac_grid + logical, dimension(im), intent(in ) :: land, icy + real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat, tice real (kind=kind_phys), dimension(im), intent(inout) :: smcref2 real (kind=kind_phys), dimension(im), intent(inout) :: smcwlt2 real (kind=kind_phys), dimension(im), intent(in ) :: tg3 @@ -1065,14 +1142,12 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, dimension(im), intent(inout) :: soiltyp integer, dimension(im), intent(inout) :: vegtype real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im), intent(inout) :: fice + real (kind=kind_phys), dimension(im), intent(in ) :: fice real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc - real (kind=kind_phys), dimension(1:lsoil_ruc), intent (out) :: zs - integer, intent(in ) :: me integer, intent(in ) :: master character(len=*), intent(out) :: errmsg @@ -1085,6 +1160,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer :: flag_soil_layers, flag_soil_levels, flag_sst real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind=kind_phys), dimension(1:lsoil_ruc) :: zs integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp @@ -1175,8 +1251,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in flag_soil_levels = 1 ! =1 for input from RUC LSM else ! for Noah input set smadj and swi_init to .true. - smadj = .true. - swi_init = .true. + smadj = .false. + swi_init = .false. flag_soil_layers = 1 ! =1 for input from the Noah LSM flag_soil_levels = 0 ! =1 for input from RUC LSM endif @@ -1198,25 +1274,29 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in endif - if(debug_print) then + !if(debug_print) then write (0,*)'smc(ipr,:) ==', ipr, smc(ipr,:) write (0,*)'stc(ipr,:) ==', ipr, stc(ipr,:) - write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) - write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) + !write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) + !write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) + write (0,*)'tskin_lnd(:)=',tskin_lnd(:) + write (0,*)'tskin_wat(:)=',tskin_wat(:) write (0,*)'its,ite,jts,jte ',its,ite,jts,jte - endif + !endif do j=jts,jte ! do i=its,ite ! i = horizontal loop + sst(i,j) = tskin_wat(i) + tbot(i,j)= tg3(i) ! land only version if (land(i)) then - tsk(i,j) = tsurf(i) - sst(i,j) = tsurf_wat(i) - tbot(i,j)= tg3(i) + tsk(i,j) = tskin_lnd(i) ivgtyp(i,j)=vegtype(i) isltyp(i,j)=soiltyp(i) + !ivgtyp(i,j )= 12 + !isltyp(i,j) = 3 landmask(i,j)=1. xice(i,j)=0. else @@ -1236,14 +1316,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in st_input(i,1,j)=tsk(i,j) sm_input(i,1,j)=0. - !--- initialize smcwlt2 and smcref2 with Noah values - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) - do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) if(swi_init) then + !--- initialize smcwlt2 and smcref2 with Noah values + smcref2 (i) = REFSMCnoah(soiltyp(i)) + smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else @@ -1299,7 +1378,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in if(debug_print) then write (0,*)'tsk(i,j),tbot(i,j),sst(i,j),landmask(i,j)' & ,ipr,1,tsk(ipr,1),tbot(ipr,1),sst(ipr,1),landmask(ipr,1) - write (0,*)'tsurf(ipr)=',ipr,tsurf(ipr) + write (0,*)'tskin_lnd(ipr)=',ipr,tskin_lnd(ipr) write (0,*)'stc(ipr)=',ipr,stc(ipr,:) write (0,*)'smc(ipr)=',ipr,smc(ipr,:) write (0,*)'soilt(1,:,ipr)',ipr,soiltemp(ipr,:,1) @@ -1390,29 +1469,34 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in ! Initialize liquid and frozen soil moisture from total soil moisture ! and soil temperature, and also soil moisture availability in the top ! layer - call ruclsminit( debug_print, landmask, & - lsoil_ruc, isltyp, ivgtyp, xice, mavail, & - soilh2o, smfr, soiltemp, soilm, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + !call ruclsminit( debug_print, frac_grid, land, icy, & + ! lsoil_ruc, isltyp, ivgtyp, mavail, & + ! soilh2o, smfr, soiltemp, soilm, & + ! ims,ime, jms,jme, kms,kme, & + ! its,ite, jts,jte, kts,kte ) do j=jts,jte do i=its,ite - if (land(i)) then - wetness(i) = mavail(i,j) - do k = 1, lsoil_ruc - smois(i,k) = soilm(i,k,j) - tslb(i,k) = soiltemp(i,k,j) - sh2o(i,k) = soilh2o(i,k,j) - smfrkeep(i,k) = smfr(i,k,j) - enddo - endif ! land(i) + if (land(i)) then + wetness(i) = soilm(i,1,j)/0.5 + !wetness(i) = mavail(i,j) + do k = 1, lsoil_ruc + smois(i,k) = soilm(i,k,j) + tslb(i,k) = soiltemp(i,k,j) + sh2o(i,k) = soilm(i,k,j) + smfrkeep(i,k) = soilm(i,k,j) + !sh2o(i,k) = soilh2o(i,k,j) + !smfrkeep(i,k) = smfr(i,k,j) + enddo + endif ! land(i) enddo enddo ! For non-land points, set RUC LSM fields to input (Noah or RUC) fields + if (.not. frac_grid) then do i=1,im if (.not.land(i)) then + wetness (i) = 1. do k=1,min(lsoil,lsoil_ruc) smois(i,k) = smc(i,k) tslb(i,k) = stc(i,k) @@ -1420,12 +1504,16 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in enddo endif enddo + endif ! frac_grid - if(debug_print) then + !if(debug_print) then + do i=1,im write (0,*)'End of RUC LSM initialization' - write (0,*)'tslb(ipr)=',ipr,tslb(ipr,:) - write (0,*)'smois(ipr)=',ipr,smois(ipr,:) - endif ! debug_print + write (0,*)'tslb(i)=',i,land(i),icy(i),tslb(i,:) + write (0,*)'smois(i)=',i,land(i),icy(i),smois(i,:) + write (0,*)'wetness(i)=',i,land(i),icy(i),wetness(i) + enddo + !endif ! debug_print end subroutine rucinit diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 4721418d3..730bcd8c0 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -9,6 +9,14 @@ type = integer intent = in optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [isot] standard_name = soil_type_dataset_choice long_name = soil type dataset choice @@ -33,6 +41,262 @@ type = integer intent = in optional = F +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_init] + standard_name = flag_for_first_time_step + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsoil_ruc] + standard_name = soil_vertical_dimension_for_land_surface_model + long_name = number of soil layers internal to land surface model + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[kice] + standard_name = ice_vertical_dimension + long_name = vertical loop extent for ice levels, start at 1 + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsm_ruc] + standard_name = flag_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in + optional = F +[land] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_lnd] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_wat] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tice] + standard_name = sea_ice_temperature_interstitial + long_name = sea ice surface skin temperature use as interstitial + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = total soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = soil water fraction at wilting point + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sh2o] + standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model + long_name = volume fraction of unfrozen soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F +[smfrkeep] + standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model + long_name = volume fraction of frozen soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F +[tslb] + standard_name = soil_temperature_for_land_surface_model + long_name = soil temperature for land surface model + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F +[smois] + standard_name = volume_fraction_of_soil_moisture_for_land_surface_model + long_name = volumetric fraction of soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F +[wetness] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tsice] + standard_name = internal_ice_temperature + long_name = sea ice internal temperature + units = K + dimensions = (horizontal_dimension,ice_vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 5bf8978f02d9672e3776106a6bfdcf8f3fb1fcb9 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 31 Aug 2020 17:57:23 +0000 Subject: [PATCH 07/45] A typo is corrected --- physics/sfcsub.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index a78ac650f..3ceded5bc 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -384,7 +384,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(snwmin=5.0,snwmax=100.) real (kind=kind_io8), parameter :: ten=10.0, one=1.0 ! -! coeficients of blending forecast and interpolated clim +! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) !tgs -- important ! 1.0 = use of forecast From ff2d8c2298265d32153979f0a5757500f481b230 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 31 Aug 2020 22:16:42 +0000 Subject: [PATCH 08/45] Added index k to printed out names of variables at K soil level. --- physics/sfcsub.F | 45 ++++++++++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 3ceded5bc..ade25055b 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -581,6 +581,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fndclm,fndanl ! logical lanom + character(len=10) :: message ! namelist/namsfc/fnglac,fnmxic, @@ -1240,7 +1241,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call getsmc(wetclm,len,lsoil,smcclm,me) endif do k=1,lsoil - call qcmxmn('smc ',smcclm(1,k),sliclm,snoclm,icefl1, + call qcmxmn(message('stc',k),smcclm(1,k),sliclm,snoclm,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -1250,7 +1251,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif do k=1,lsoil - call qcmxmn('stc ',stcclm(1,k),sliclm,snoclm,icefl1, + call qcmxmn(message('stc',k),stcclm(1,k),sliclm,snoclm,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -1314,8 +1315,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('snoclm',snoclm,sliclm,snoclm,len) call monitr('scvclm',scvclm,sliclm,snoclm,len) do k=1,lsoil - call monitr('smcclm1',smcclm(1,k),sliclm,snoclm,len) - call monitr('stcclm1',stcclm(1,k),sliclm,snoclm,len) + call monitr(message('smcclm',k),smcclm(1,k),sliclm,snoclm,len) + call monitr(message('stcclm',k),stcclm(1,k),sliclm,snoclm,len) enddo call monitr('tg3clm',tg3clm,sliclm,snoclm,len) call monitr('zorclm',zorclm,sliclm,snoclm,len) @@ -1610,7 +1611,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif !-- soil moisture do k=1,lsoil - call qcmxmn('smca ',smcanl(1,1),slianl,snoanl,icefl1, + call qcmxmn(message('smca',k),smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -1620,7 +1621,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif do k=1,lsoil - call qcmxmn('stca ',stcanl(1,1),slianl,snoanl,icefl1, + call qcmxmn(message('stca',k),stcanl(1,1),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -1671,8 +1672,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('snoanl',snoanl,slianl,snoanl,len) call monitr('scvanl',scvanl,slianl,snoanl,len) do k=1,lsoil - call monitr('smcanl',smcanl(1,k),slianl,snoanl,len) - call monitr('stcanl',stcanl(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) enddo call monitr('tg3anl',tg3anl,slianl,snoanl,len) call monitr('zoranl',zoranl,slianl,snoanl,len) @@ -1844,14 +1845,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) !-- soil moisture forecast do k=1,lsoil - call qcmxmn('smcf ',smcfcs(1,k),slifcs,snofcs,icefl1, + call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs,snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo !-- soil temperature forecast do k=1,lsoil - call qcmxmn('stcf ',stcfcs(1,k),slifcs,snofcs,icefl1, + call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs,snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -1902,8 +1903,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisfcs',aisfcs,slifcs,snofcs,len) call monitr('snofcs',snofcs,slifcs,snofcs,len) do k=1,lsoil - call monitr('smcfcs',smcfcs(1,k),slifcs,snofcs,len) - call monitr('stcfcs',stcfcs(1,k),slifcs,snofcs,len) + call monitr(message('smcfcs',k),smcfcs(1,k),slifcs,snofcs,len) + call monitr(message('stcfcs',k),stcfcs(1,k),slifcs,snofcs,len) enddo call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) call monitr('zorfcs',zorfcs,slifcs,snofcs,len) @@ -2048,13 +2049,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & rla,rlo,len,kqcm,percrit,lgchek,me) ! endif do k=1,lsoil - call qcmxmn('stcm ',stcanl(1,k),slianl,snoanl,icefl1, + call qcmxmn(message('stcm',k),stcanl(1,k),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo do k=1,lsoil - call qcmxmn('smcm ',smcanl(1,k),slianl,snoanl,icefl1, + call qcmxmn(message('smcm',k),smcanl(1,k),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -2142,7 +2143,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisanl',aisanl,slianl,snoanl,len) call monitr('snoanl',snoanl,slianl,snoanl,len) do k=1,lsoil - call monitr('smcanl',smcanl(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) call monitr('stcanl',stcanl(1,k),slianl,snoanl,len) enddo call monitr('tg3anl',tg3anl,slianl,snoanl,len) @@ -2221,8 +2222,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisdif',aisfcs,slianl,snoanl,len) call monitr('snodif',snofcs,slianl,snoanl,len) do k=1,lsoil - call monitr('smcanl',smcfcs(1,k),slianl,snoanl,len) - call monitr('stcanl',stcfcs(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcfcs(1,k),slianl,snoanl,len) + call monitr('stcanl(k)',stcfcs(1,k),slianl,snoanl,len) enddo call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) @@ -8605,4 +8606,14 @@ subroutine snodpth2(glacir,snwmax,snoanl, len, me) enddo return end + function message(prefix,index) + implicit none + character(len=*), intent(in) :: prefix + integer, intent(in) :: index + character(len=10) :: message + ! + ! probably need to implement a check that len(prefix) + '-' + length of + ! string representation of index <= len(message) + write(message,fmt='(a,a,i0)') trim(prefix), '-', index + end function message !>@} From 98e378f0f7f50a3a72cf9eb4ed4c7085de8cccbb Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 1 Sep 2020 00:09:46 +0000 Subject: [PATCH 09/45] Removed the message definition. --- physics/rte-rrtmgp | 2 +- physics/sfcsub.F | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 6ee0b62c1..7dfff2025 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 6ee0b62c1ac6204a89a4e922382b611c16dd5fa7 +Subproject commit 7dfff2025cae02c84b12df2402a39d77065f0e62 diff --git a/physics/sfcsub.F b/physics/sfcsub.F index ade25055b..41110c7c5 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -581,7 +581,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fndclm,fndanl ! logical lanom - character(len=10) :: message ! namelist/namsfc/fnglac,fnmxic, From 361cc15b6328f6754127aad337de2e7f93c9f8a7 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 2 Sep 2020 16:59:25 +0000 Subject: [PATCH 10/45] Syntax errors corrected. Still has an issue in compilation with the use 0f function message. --- physics/sfcsub.F | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 41110c7c5..a9328f9bf 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -1844,14 +1844,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) !-- soil moisture forecast do k=1,lsoil - call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs,snofcs,icefl1, + call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs, + & snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo !-- soil temperature forecast do k=1,lsoil - call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs,snofcs,icefl1, + call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs, + & snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) @@ -8605,6 +8607,8 @@ subroutine snodpth2(glacir,snwmax,snoanl, len, me) enddo return end + +!>\ingroup mod_sfcsub function message(prefix,index) implicit none character(len=*), intent(in) :: prefix @@ -8615,4 +8619,5 @@ function message(prefix,index) ! string representation of index <= len(message) write(message,fmt='(a,a,i0)') trim(prefix), '-', index end function message + !>@} From cc1d5bdaea82a880e695f19205a2203ac2eb751d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Sep 2020 13:35:58 -0600 Subject: [PATCH 11/45] Revert change to rte-rrtmgp submodule pointer --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 7dfff2025..6ee0b62c1 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 7dfff2025cae02c84b12df2402a39d77065f0e62 +Subproject commit 6ee0b62c1ac6204a89a4e922382b611c16dd5fa7 From 922c05f452ee3f8c58410672002d371fd1eb0838 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Sep 2020 13:36:20 -0600 Subject: [PATCH 12/45] physics/sfcsub.F: move message into sfccyc_module --- physics/sfcsub.F | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index a9328f9bf..30f663ec5 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -36,6 +36,20 @@ module sfccyc_module integer :: veg_type_landice integer :: soil_type_landice ! +! + contains + + function message(prefix,index) + implicit none + character(len=*), intent(in) :: prefix + integer, intent(in) :: index + character(len=10) :: message + ! + ! probably need to implement a check that len(prefix) + '-' + length of + ! string representation of index <= len(message) + write(message,fmt='(a,a,i0)') trim(prefix), '-', index + end function message + end module sfccyc_module !>\ingroup mod_GFS_phys_time_vary @@ -8608,16 +8622,4 @@ subroutine snodpth2(glacir,snwmax,snoanl, len, me) return end -!>\ingroup mod_sfcsub - function message(prefix,index) - implicit none - character(len=*), intent(in) :: prefix - integer, intent(in) :: index - character(len=10) :: message - ! - ! probably need to implement a check that len(prefix) + '-' + length of - ! string representation of index <= len(message) - write(message,fmt='(a,a,i0)') trim(prefix), '-', index - end function message - !>@} From 45cfe52756e7bd7a839e56ce2574840cbb8349b8 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 2 Sep 2020 22:09:32 +0000 Subject: [PATCH 13/45] 1st attempt - Sept. 2 --- physics/GFS_GWD_generic.F90 | 2 +- physics/cires_orowam2017.F90 | 347 +++++++ physics/cires_ugwp_initialize_v1.F90 | 799 ++++++++++++++++ physics/cires_ugwp_module_v1.F90 | 666 +++++++++++++ physics/cires_ugwp_ngw_utils.F90 | 73 ++ physics/cires_ugwp_orolm97_v1.F90 | 985 ++++++++++++++++++++ physics/cires_ugwp_solv2_v1_mod.F90 | 810 ++++++++++++++++ physics/cires_ugwp_triggers_v1.F90 | 576 ++++++++++++ physics/cires_vert_orodis.F90 | 8 + physics/drag_suite.F90 | 67 +- physics/drag_suite.meta | 24 + physics/unified_ugwp.F90 | 686 ++++++++++++++ physics/unified_ugwp.meta | 1296 ++++++++++++++++++++++++++ physics/unified_ugwp_post.F90 | 83 ++ physics/unified_ugwp_post.meta | 315 +++++++ 15 files changed, 6708 insertions(+), 29 deletions(-) create mode 100644 physics/cires_orowam2017.F90 create mode 100644 physics/cires_ugwp_initialize_v1.F90 create mode 100644 physics/cires_ugwp_module_v1.F90 create mode 100644 physics/cires_ugwp_ngw_utils.F90 create mode 100644 physics/cires_ugwp_orolm97_v1.F90 create mode 100644 physics/cires_ugwp_solv2_v1_mod.F90 create mode 100644 physics/cires_ugwp_triggers_v1.F90 create mode 100644 physics/unified_ugwp.F90 create mode 100644 physics/unified_ugwp.meta create mode 100644 physics/unified_ugwp_post.F90 create mode 100644 physics/unified_ugwp_post.meta diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 index 09c969162..ed3ff4484 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic.F90 @@ -83,7 +83,7 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = 0.0 clx(:,3) = 0.0 clx(:,4) = 0.0 - elseif (nmtvr == 24) then ! GSD_drag_suite + elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) diff --git a/physics/cires_orowam2017.F90 b/physics/cires_orowam2017.F90 new file mode 100644 index 000000000..752c6f84e --- /dev/null +++ b/physics/cires_orowam2017.F90 @@ -0,0 +1,347 @@ +module cires_orowam2017 + + +contains + + + subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, + & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, + & del, sigma, hprime, gamma, theta, + & sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys + use ugwp_common , only : grav, omega2 +! + implicit none + + integer :: im, levs + integer :: npt + integer :: kdt, me, master + integer :: kref(im), ipt(im) + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, + & hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: + & u1, v1, t1, bn2, rho, prsl, del + + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi +! +! out : taup, taud, pkdis +! + real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup + real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud + real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis + real(kind=kind_phys) :: belps, aelps, nhills, selps +! +! multiwave oro-spectra +! locals +! + integer :: i, j, k, isp, iw + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real :: akx(nworo), cxoro(nworo), akx2(nworo) + real :: aspkx(nworo), c2f2(nworo) , cdf2(nworo) + real :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real :: tau_kx(nworo),taub_kx(nworo) + real, dimension(nworo, levs+1) :: wrms, akzw + + real :: tauz(levs+1), rms_wind(levs+1) + real :: wave_act(nworo,levs+1) + + real :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real :: rayf, kturb + real :: uz, bv, bv2,kxsp, fcor2, cf2 + + real :: fdis + real :: wfdm, wfdt, wfim, wfit + real :: betadis, betam, betat, kds, cx, rhofac + real :: etwk, etws, tauk, cx2sat + real :: cdf1, tau_norm +! +! mean flow +! + real, dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + + integer :: nw, nzi, ksrc + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then +771 format( 'vay-oro19 ', 3(2x,F8.3)) + write(6,771) + & maxval(tau_kx)*maxval(taub)*1.e3, + & minval(tau_kx), maxval(tau_kx) + endif +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), + & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, + & xn(i), yn(i)) + + fcor2 = (omega2*sinlat(j))*(omega2*sinlat(j))*fc_flag + + k = ksrc + + bv2 = bn2(i,k) + uz = uzi(k) !u1(j,ksrc)*xn(i)+v1(j,ksrc)*yn(i)! + kturb = ktur(k) + rayf = kalp(k) + rhoint = rhoi(k) + dzmet = dzi(k) + kzw = max(sqrt(bv2)/max(cxmin, uz), mkzmin) +! +! specify oro-kx spectra and related variables k=ksrc +! + do iw = 1, nw + kxw = akx(iw) + cxoro(iw) = 0.0 - uz + c2f2(iw) = fcor2/akx2(iw) + wrms(iw,k)= taub_kx(iw)/rhoint*kzw/kxw + tau_sp(iw, k) = taub_kx(iw) +! +! + if (cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0. ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) then + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off + else + kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) + kzw = sqrt(kzw2) + akzw(iw,k)= kzw + wrms(iw,k)= taub_kx(iw)/rhoint * kzw/kxw + endif + endif + enddo ! nw-spectral loop +! +! defined abobe, k = ksrc: akx(nworo), cxoro(nworo), tau_sp(ksrc, nworo) +! propagate upward multiwave-spectra are filtered by dissipation & instability +! +! tau_sp(:,ksrc+1:levs+1) = tau_sp(:, ksrc) + do k= ksrc+1, levs + uz = uzi(k) + bv2 =bn2(i,k) + bv = sqrt(bv2) + rayf = kalp(k) + rhoint= rhoi(k) + dzmet = dzi(k) + rhofac = rhoi(k-1)/rhoi(k) + + do iw = 1, nworo +! + if (wave_act(iw, k-1) <= 0.0) cycle + cxoro(iw)= 0.0 - uz + if ( cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0.0 ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) wave_act(iw,k:levs+1) = 0.0 + endif + if ( wave_act(iw,k) <= 0.0) cycle +! +! upward propagation +! + kzw2 = Bv2/Cdf2(iw) - akx2(iw) + + if (kzw2 < mkz2min) then + wave_act(iw,k:levs+1) = 0.0 + else +! +! upward propagation w/o reflection +! + kxw = akx(iw) + kzw = sqrt(kzw2) + akzw(iw,k) = kzw + kzw3 = kzw2*kzw + + cx = cxoro(iw) + betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + kds = wkdis(iw,k-1) + + etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) + + kturb = ktur(k)+pkdis(j,k-1) + wfiM = kturb*kzw2 +rayf + wfiT = wfiM ! do updates with Pr-numbers Kv/Kt + cdf1 = sqrt(Cdf2(iw)) + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cdf1)*BetaT + kzi = 2.*kzw*(wfdM+wfdT)*dzmet + Fdis = exp(-kzi) + + etwk = etws*Fdis + Cx2sat = Linsat2*Cdf2(iw) + + if (etwk > cx2sat) then + Kds = kxw*Cdf1*rhp2/kzw3 + etwk = cx2sat + wfiM = kds*kzw2 + wfdM = wfiM/(kxw*Cdf1) + kzi = 2.*kzw*(wfdm + wfdm)*dzmet + etwk = cx2sat*exp(-kzi) + endif +! if( lat(j) eq 40.5 ) then stop + wkdis(iw,k) = kds + wrms(iw,k) = etwk + tauk = etwk*kxw/kzw + tau_sp(iw,k) = tauk *rhoint + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) + & tau_sp(iw,k) = tau_sp(iw,k-1) + + ENDIF ! upward + ENDDO ! spectral + +!......... do spectral sum of rms, wkdis, tau + + tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) + rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau + + if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax + + ENDDO ! k=ksrc+1, levs + + k = ksrc + tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) + tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) + rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) + tauz(levs+1) = tauz(levs) + taup(i, 1:levs+1) = tauz(1:levs+1) + do k=ksrc, levs + taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +!23456 + end subroutine oro_wam_2017 +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + + use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min + implicit none + + integer :: nz, nzi + real, dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real, dimension(nz ) :: bn2 ! define at the interfaces + real, dimension(nz+1) :: pint + real :: xn, yn +! output + + real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real :: zgrow, zmet, rdpm, ritur, kmol, w1 +! paremeters + real, parameter :: hps = 7000., rpspa = 1.e-5 + real, parameter :: rhps=1.0/hps + real, parameter :: h4= 0.25/hps + real, parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real, parameter :: lturb = 30. , uturb = 150.0 + real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + kalp(1:nzi) = 2.e-7 ! radiative damping + + do k=2, nz + rdpm = grav/(pmid(k-1)-pmid(k)) + ui = .5*(u1(k-1)+u1(k)) + vi = .5*(v1(k-1)+v1(k)) + uzi(k) = Ui*xn + Vi*yn + ti = .5*(t1(k-1)+t1(k)) + rhoi(k) = rdi*pint(k)/ti + rdz = rdpm *rhoi(k) + dzi(k) = 1./rdz + uz = u1(k)-u1(k-1) + vz = v1(k)-v1(k-1) + shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) + zmet = -hps*alog(pint(k)*rpspa) + zgrow = exp(zmet*h4) + kmol = 2.e-5*exp(zmet*rhps)+kedmin + ritur = max(bn2(k)/shr2, rimin) + kamp = sqrt(shr2)*lsc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k) = kamp * w1 * w1 +kmol + enddo + + k = 1 + uzi(k) = uzi(k+1) + ktur(k) = ktur(k+1) + rhoi(k) = rdi*pint(k)/t1(k+1) + dzi(k) = rgrav*delp(k)/rhoi(k) + + k = nzi + uzi(k) = uzi(k-1) + ktur(k) = ktur(k-1) + rhoi(k) = rhoi(k-1)*.5 + dzi(k) = dzi(k-1) + + end subroutine oro_meanflow + +end module cires_orowam2017 diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 new file mode 100644 index 000000000..eef5cc04e --- /dev/null +++ b/physics/cires_ugwp_initialize_v1.F90 @@ -0,0 +1,799 @@ +!=============================== +! cu-cires ugwp-scheme +! initialization of selected +! init gw-solvers (1,2,3,4) +! init gw-source specifications +! init gw-background dissipation +!============================== +! +! Part-0 specifications of common constants, limiters and "criiical" values +! +! + + module ugwp_common +! +! use machine, only : kind_phys +! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & +! rv => con_rv, cpd => con_cp, fv => con_fvirt,& +! arad => con_rerth + implicit none + + real, parameter :: grav =9.81, cpd = 1004. + real, parameter :: rd = 287.0 , rv =461.5 + real, parameter :: grav2 = grav + grav + real, parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real, parameter :: fv = rv/rd - 1.0 + real, parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd + real, parameter :: gor = grav/rd + real, parameter :: gr2 = grav*gor + real, parameter :: grcp = grav*rcpd, gocp = grcp + real, parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + real, parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + + real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi + real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 + + real, parameter :: arad = 6370.e3 +! + real, parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) + real, parameter :: bnv2max = (pi2/30.)*(pi2/30.) + + real, parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 + real, parameter :: omega1 = pi2/86400. + real, parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 + real, parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp + real, parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin + real, parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax + real, parameter :: cdmin = 2.e-2/mkzmax + end module ugwp_common +! +! +!=================================================== +! +!Part-1 init => wave dissipation + RFriction +! +!=================================================== + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + + use ugwp_common, only : pih + + + implicit none + integer , intent(in) :: me, master + integer , intent(in) :: levs + real, intent(in) :: pa_rf, tau_rf + real, intent(in) :: zkm(levs), pmb(levs) ! in km-Pa + real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion +! +!locals + data +! + integer :: k + real, parameter :: vusurf = 2.e-5 + real, parameter :: musurf = vusurf/1.95 + real, parameter :: hpmol = 8.5 +! + real, parameter :: kzmin = 0.1 + real, parameter :: kturbo = 100. + real, parameter :: zturbo = 130. + real, parameter :: zturw = 30. + real, parameter :: inv_pra = 3. !kt/kv =inv_pr +! + real, parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days + real :: pa_alp = 750. ! super-RF parameters + real :: tau_alp = 10. ! days (750 Pa /10days) +! + real, parameter :: kdrag = 1./86400./30. !parametrization for WAM for FV3GFS SuperRF + real, parameter :: zdrag = 100. + real, parameter :: zgrow = 50. +! + real :: vumol, mumol, keddy, ion_drag + real :: rf_fv3, rtau_fv3, ptop, pih_dlog +! + real :: ae1 ,ae2 + pa_alp = pa_rf + tau_alp = tau_rf + + ptop = pmb(levs) + rtau_fv3 = 1./86400./tau_alp + pih_dlog = pih/log(pa_alp/ptop) + + do k=1, levs + ae1 = -zkm(k)/hpmol + vumol = vusurf*exp(ae1) + mumol = musurf*exp(ae1) + ae2 = -((zkm(k)-zturbo) /zturw)**2 + keddy = kturbo*exp(ae2) + + kvg(k) = vumol + keddy + ktg(k) = mumol + keddy*inv_pra + + krad(k) = alpha +! + ion_drag = kdrag +! + kion(k) = ion_drag! +! add Rayleigh_Super of FV3 for pmb < pa_alp +! + if (pmb(k) .le. pa_alp) then + rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 + krad(k) = krad(k) + rf_fv3 + kion(k) = kion(k) + rf_fv3 + + endif + +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) + enddo + + k= levs+1 + kion(k) = kion(k-1) + krad(k) = krad(k-1) + kvg(k) = kvg(k-1) + ktg(k) = ktg(k-1) + if (me == master) then + write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ' + do k=1, levs, 1 + write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) + enddo + endif +! + 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) + + end subroutine init_global_gwdis +! +! + subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + implicit none + + integer :: levs + real :: pa_rf, tau_rf + real :: dtp + + real :: pmb(levs) + real :: rfdis(levs), rfdist(levs) + integer :: levs_rf + + real :: krf, krfz + integer :: k +! + rfdis(1:levs) = 1.0 + rfdist(1:levs) = 0.0 + levs_rf = levs + if (tau_rf <= 0.0 .or. pa_rf == 0.0) return + + krf = 1.0/(tau_rf*86400.0) + + do k=levs, 1, -1 + if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" + krfz = krf*log(pa_rf/pmb(k)) + rfdis(k) = 1.0/(1.+krfz*dtp) + rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp + levs_rf = k + endif + enddo + + end subroutine rf_damp_init +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init +! +!========================================================================= + module ugwp_oro_init + + use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common, only : mkzmin, mkz2min + implicit none +! +! constants and "crirtical" values to run oro-mtb_gw physics +! +! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' +! +! + real, parameter :: hncrit=9000. ! max value in meters for elvmax + real, parameter :: hminmt=50. ! min mtn height (*j*) + real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor +! +! + real, parameter :: minwnd=1.0 ! min wind component (*j*) + real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + real, parameter :: hpmax=2400.0, hpmin=25.0 + + character(len=8) :: strver = 'gfs_2018' + character(len=8) :: strbase = 'gfs_2018' + real, parameter :: rimin=-10., ric=0.25 + +! + real, parameter :: efmin=0.5, efmax=10.0 + + + real, parameter :: sigma_std=1./100., gamm_std=1.0 + + real, parameter :: frmax=10., frc =1.0, frmin =0.01 +! + + real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 +! + real, parameter :: rlolev=50000.0 +! + + +! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt + + + + real, parameter :: kxoro=6.28e-3/200. ! + real, parameter :: coro = 0.0 + integer, parameter :: nridge=2 + + real :: cdmb ! scale factors for mtb + real :: cleff ! scale factors for orogw + integer :: nworo ! number of waves + integer :: nazoro ! number of azimuths + integer :: nstoro ! flag for stochastic launch above SG-peak + + integer, parameter :: mdir = 8 + real, parameter :: fdir=.5*mdir/pi + + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir + + real, parameter :: odmin = 0.1, odmax = 10.0 +!------------------------------------------------------------------------------ +! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS +!------------------------------------------------------------------------------ + + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters + real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km +!------------------------------------------------------------------------------ +! + real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm + real, parameter :: fcrit_gfs = 0.7 + real, parameter :: fcrit_mtb = 0.7 + + real, parameter :: zbr_pi = (1.0/2.0)*pi + real, parameter :: zbr_ifs = 0.5*pi + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw, cdmbgwd ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) + ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 + real :: cdmbX + real :: kxw + real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now +!-----------------------------! GFS-setup for cdmb & cleff +! cdmb = 4.0 * (192.0/IMX) +! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) +! + real, parameter :: lonr_refmb = 4.0 * 192.0 + real, parameter :: lonr_refgw = 192.0 + +! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + cdmb = cdmbX + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + + cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac + +!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac + + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +! +!.................................................................... +! higher res => smaller h' ..&.. higher kx +! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) +!.................................................................... +! +! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) + end subroutine init_oro_gws +! + + end module ugwp_oro_init +! ========================================================================= +! +! ugwp_conv_init +! +!========================================================================= + module ugwp_conv_init + + implicit none + real :: eff_con ! scale factors for conv GWs + integer :: nwcon ! number of waves + integer :: nazcon ! number of azimuths + integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud + real :: con_dlength + real :: con_cldf + + real, parameter :: cmin = 5 !2.5 + real, parameter :: cmax = 95. !82.5 + real, parameter :: cmid = 22.5 + real, parameter :: cwid = cmid + real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real, parameter :: mstar = 6.28e-3/2. ! 2km + real :: dc + + real, allocatable :: ch_conv(:), spf_conv(:) + real, allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw, cgwf) + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: cgwf(2) + real :: kxw, effac + real :: work1 = 0.5 + real :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = pi2*arad/float(lonr) + con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) +! +! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" +! + if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) + if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) + if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) + if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) +! +! we may use different spectral "shapes" +! for example FVS-93 "Desabeius" +! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail +! + do k = 1,nwaves + chk = cmin + (k-1)*dc + tn4 = (mstar*chk)**4 + ch_conv(k) = chk + spf_conv(k) = bns4*chk/(bns4+tn4) + enddo + + snorm = sum(spf_conv) + spf_conv = spf_conv/snorm*1.5 + + call init_nazdir(nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init +!========================================================================= +! +! ugwp_fjet_init +! +!========================================================================= + + module ugwp_fjet_init + implicit none + real :: eff_fj ! scale factors for conv GWs + integer :: nwfj ! number of waves + integer :: nazfj ! number of azimuths + integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_fjet(:) , spf_fjet(:) + real, allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: kxw, effac , chk + + integer :: k + + nwfj = nwaves + nazfj = nazdir + nstfj = nstoch + eff_fj = effac + + if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) + if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) + if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) + if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_fjet(k) = chk + spf_fjet(k) = 1.0 + enddo + call init_nazdir(nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init +! +!========================================================================= +! +! + module ugwp_okw_init +!========================================================================= + implicit none + + real :: eff_okw ! scale factors for conv GWs + integer :: nwokw ! number of waves + integer :: nazokw ! number of azimuths + integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_okwp(:), spf_okwp(:) + real, allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: kxw, effac , chk + + integer :: k + + nwokw = nwaves + nazokw = nazdir + nstokw = nstoch + eff_okw = effac + + if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) + if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) + if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) + if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_okwp(k) = chk + spf_okwp(k) = 1. + enddo + + call init_nazdir(nazdir, xaz_okwp, yaz_okwp) + + end subroutine init_okw_gws + + end module ugwp_okw_init + +!=============================== end of GW sources +! +! init specific gw-solvers (1,2,3,4) +! + +!=============================== +! Part -3 init wave solvers +!=============================== + + module ugwp_lsatdis_init + implicit none + + integer :: nwav, nazd + integer :: nst + real :: eff + integer, parameter :: incdim = 4, iazdim = 4 +! + contains + + subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + + implicit none +! + integer :: me, master + integer :: nwaves, nazdir + integer :: nstoch + real :: effac + logical :: do_physb + real :: kxw +! +!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces +! are not actibve +! + integer :: inc, jk, jl, iazi, i, j, k + + if( nwaves == 0 .or. nstoch == 1 ) then +! redefine from the default + nwav = incdim + nazd = iazdim + nst = 0 + eff = 1.0 + else +! from input_nml multi-wave spectra + nwav = nwaves + nazd = nazdir + nst = nstoch + eff = effac + endif +! + end subroutine initsolv_lsatdis +! + end module ugwp_lsatdis_init +! +! + module ugwp_wmsdis_init + + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 + use ugwp_common, only : bnv2max, bnv2min, minvel + use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin + implicit none + + real, parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 + real, parameter :: dked_min =0.01, dked_max=250.0 + + real, parameter :: gptwo=2.0 + + real , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real , parameter :: bnfix4 = bnfix2 * bnfix2 + real , parameter :: bnfix3 = bnfix2 * bnfix +! +! make parameter list that will be passed to SOLVER +! +! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level +! integer, parameter :: ilaunch=klaunch + + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + real , parameter :: ucrit=cdmin + + real , parameter :: zcimin = 2.5 + real , parameter :: zcimax = 125.0 + real , parameter :: zgam = 0.25 +! +! Verical spectra +! + real , parameter :: pind_wd = 5./3. + real , parameter :: sind_kz = 1. + real , parameter :: tind_kz = 3. + real , parameter :: stind_kz = sind_kz + tind_kz +! +! from kmob_ugwp namelist +! + real :: nslope ! the GW sprctral slope at small-m + real :: lzstar + real :: lzmin + real :: lzmax + real :: lhmet + real :: tamp_mpa !amplitude for GEOS-5/MERRA-2 + real :: tau_min ! min of GW MF 0.25 mPa + integer :: ilaunch + real :: gw_eff + + real :: v_kxw, rv_kxw, v_kxw2 + + + +!=========================================================================== + integer :: nwav, nazd, nst + real :: eff + + real :: zaz_fct, zms + real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real, allocatable :: zcosang(:), zsinang(:) + real, allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) + +! +! GW-eddy constants for wave-mode dissipation by background and stability of +! "final" flow after application of GW-effects +! + real, parameter :: iPr_pt = 0.5 + real, parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. + real, parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable + real, parameter :: ric =0.25 + real, parameter :: rimin = -10., prmin = 0.25 + real, parameter :: prmax = 4.0 +! + contains +!============================================================================ + subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + +! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & +! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) +! + implicit none +! +!input -control for solvers: +! nwaves, nazdir, nstoch, effac, do_physb, kxw +! +! + integer :: me, master, nwaves, nazdir, nstoch + real :: effac, kxw + logical :: do_physb + real :: dlzmet +! +!locals +! + integer :: inc, jk, jl, iazi +! + real :: zang, zang1, znorm + real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + real :: fpc, fpc_dc + real :: ae1,ae2 + if( nwaves == 0) then +! +! redefine from the deafault +! + nwav = incdim + nazd = iazidim + nst = 0 + eff = 1.0 + gw_eff = eff + else +! +! from input.nml +! + nwav = nwaves + nazd = nazdir + nst = nstoch + gw_eff = effac + endif + + + v_kxw = pi2/lhmet ; v_kxw2 = v_kxw*v_kxw + rv_kxw = 1./v_kxw + + allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) + allocate ( zcosang(nazd), zsinang(nazd) ) + allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) + + if (me == master) then + print *, 'ugwp_v1: init_gw_wmsdis_control ' +! + print *, 'ugwp_v1: WMS_DIS launch layer ', ilaunch + print *, 'ugwp_v1: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. + print *, 'ugwp_v1: WMS_DIS lhmet in km ' , lhmet*1.e-3 + endif + + zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. + +! +! set up azimuth directions and some trig factors +! +! + zang = pi2 / float(nazd) + +! get normalization factor to ensure that the same amount of momentum +! flux is directed (n,s,e,w) no mater how many azimuths are selected. +! + znorm = 0.0 + do iazi=1, nazd + zang1 = (iazi-1)*zang + zcosang(iazi) = cos(zang1) + zsinang(iazi) = sin(zang1) + znorm = znorm + abs(zcosang(iazi)) + enddo +! zaz_fct = 1.0 + zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums + +! define coordinate transform for "Ch" ....x = 1/c stretching transform +! ----------------------------------------------- +! +! x=1/Cphase transform +! see eq. 28-30 Scinocca 2003. x = 1/c stretching transform +! + zxmax = 1.0 / zcimin + zxmin = 1.0 / zcimax + zxran = zxmax - zxmin + zdx = zxran / real(nwav-1) ! dkz +! + ae1=zxran/zgam + zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. + zx2 = zxmin - zx1 + +! +! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform +! it represents additional "empirical" redistribution of "spectral" mode in C-space +! + zms = pi2 / lzstar + + do inc=1, nwav + ztx = real(inc-1)*zdx+zxmin + ae1 = (ztx-zxmin)/zgam + zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 + zci(inc) = 1.0 /zx ! + zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + enddo +! +! +! alternatuve lzmax-lzmin +! +! + dlzmet = (lzmax-lzmin)/ real(nwav-1) + do inc=1, nwav + lzmet(inc) = lzmin + (inc-1)*dlzmet + mkzmet(inc) = pi2/lzmet(inc) + zci(inc) =lzmet(inc)/(pi2/bnfix) + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + + enddo + + zdx = (zci(nwav)-zci(1))/ real(nwav-1) + + + if (me == master) then + print * + print *, 'ugwp_v0: zcimin=' , zcimin + print *, 'ugwp_v0: zcimax=' , zcimax + print *, 'ugwp_v0: zgam= ', zgam + print * + +! print *, ' ugwp_v1 nslope=', nslope + print * + print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) + print *, 'ugwp_v1: zcimax/zci=' , minval(zci) + print *, 'ugwp_v1: cd_crit=', ucrit + print *, 'ugwp_v1: launch_level', ilaunch + print *, ' ugwp_v1 lzstar=', lzstar + print *, ' ugwp_v1 nslope=', nslope + + print * + do inc=1, nwav + zdci(inc) = zdx + if (nslope == 1) fpc = bnfix4*zci(inc)/ (bnfix4+zci4(inc)) + if (nslope == 0) fpc = bnfix3*zci(inc)/ (bnfix3+zci3(inc)) + fpc_dc = fpc * zdci(inc) + write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) + enddo + endif + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) + + end subroutine initsolv_wmsdis +! +! make a list of all-initilized parameters needed for "gw_solver_wmsdis" +! + + end module ugwp_wmsdis_init +!========================================================================= +! +! work TODO for 2-extra WAM-solvers: +! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) +! +!========================================================================= + subroutine init_dspdis + implicit none + end subroutine init_dspdis + + subroutine init_adodis + implicit none + end subroutine init_adodis + diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 new file mode 100644 index 000000000..ecc00ecfb --- /dev/null +++ b/physics/cires_ugwp_module_v1.F90 @@ -0,0 +1,666 @@ + +module cires_ugwp_module_v1 + +! +! driver is called after pbl & before chem-parameterizations +! it uses ugwp_common (like phys_cons) and some module-param od solvers/sources init-modules +!.................................................................................... +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +!................................................................................... +! +! + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + implicit none + logical :: module_is_initialized +!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction + character(len=8) :: strsolver='pss-1986' + logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources + logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver + integer, parameter :: idebug_gwrms=1 ! control for diag computaions pw wind-temp GW-rms and MF fluxs + logical, parameter :: do_adjoro = .false. + real, parameter :: max_kdis = 250. ! 400 m2/s + real, parameter :: max_axyz = 250.e-5 ! 400 m/s/day + real, parameter :: max_eps = max_kdis*4.e-7 ! ~16 K/day max_kdis*BN2/cp + real, parameter :: maxdudt = max_axyz + real, parameter :: maxdtdt = max_eps + real, parameter :: dked_min = 0.01 + real, parameter :: dked_max = max_kdis + + + real, parameter :: hps = hpscale + real, parameter :: hpskm = hps/1000. +! + + real, parameter :: ricrit = 0.25 + real, parameter :: frcrit = 0.50 + real, parameter :: linsat = 1.00 + real, parameter :: linsat2 = linsat*linsat +! +! integer :: curday_ugwp ! yyyymmdd 20150101 +! integer :: ddd_ugwp ! ddd of year from 1-366 + + integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) + integer, dimension(4) :: knob_ugwp_source ! [1,1,1,0] - (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_wvspec ! number of waves for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_azdir ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_stoch ! 1 - deterministic ; 0 - stochastic + real, dimension(4) :: knob_ugwp_effac ! efficiency factors for- (oro, fronts, conv, imbf-owp] + + integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag + integer :: knob_ugwp_doheat=1 ! 1 -gwheat + integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing + integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw + integer :: knob_ugwp_nslope = 1 ! spectral"growth" S-slope of GW-energy spectra mkz^S + + real :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs + real :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra + real :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km + real :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra + real :: knob_ugwp_taumin = 0.25e-3 + real :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) + real :: knob_ugwp_lhmet = 200.e3 ! 200 km + real :: knob_ugwp_tlimb = .true. +! + real :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes +! +! tune-ups for qbo +! + real :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs + real :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians + real :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing + real :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO + real :: knob_ugwp_qbotau = 10. ! relaxation time scale in days + real :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing + real :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing + character(len=8) :: knob_ugwp_orosolv='pss-1986' + + character(len=255) :: ugwp_qbofile = 'qbo_zmf_2009_2018.nc' + character(len=255) :: ugwp_taufile = 'ugwp_limb_tau.nc' + +! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! +! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' +! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' + +! integer, parameter :: ny_tab=73, nt_tab=14 +! real, parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. +! real :: days_tab(nt_tab), lat_tab(ny_tab) +! real :: abmf_tab(ny_tab,nt_tab) + + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + real :: ugwp_effac + +! + data knob_ugwp_source / 1,0, 1, 0 / ! oro-conv-fjet-okw-taub_lat: 1-active 0-off + data knob_ugwp_wvspec /1,32,32,32/ ! number of waves for- (oro, fronts, conv, imbf-owp, taulat] + data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] + data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option + data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] + integer :: knob_ugwp_version = 0 + integer :: launch_level = 55 +! + namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & + knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & + knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & + knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & + knob_ugwp_qbolev, knob_ugwp_qbosin, knob_ugwp_qbotav, knob_ugwp_qboamp, knob_ugwp_qbotau, & + knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_tlimb, knob_ugwp_orosolv + +!&cires_ugwp_nml +! knob_ugwp_solver=2 +! knob_ugwp_source=1,1,1,0 +! knob_ugwp_wvspec=1,32,32,32 +! knob_ugwp_azdir =2, 4, 4,4 +! knob_ugwp_stoch =0, 0, 0,0 +! knob_ugwp_effac=1, 1, 1,1 +! knob_ugwp_doaxyz=1 +! knob_ugwp_doheat=1 +! knob_ugwp_dokdis=0 +! knob_ugwp_ndx4lh=4 +!/ +! +! allocatable arrays, initilized during "cires_ugwp_init" & +! released during "cires_ugwp_finalize" +! + real, allocatable :: kvg(:), ktg(:), krad(:), kion(:) + real, allocatable :: zkm(:), pmb(:) + real, allocatable :: rfdis(:), rfdist(:) + integer :: levs_rf + real :: pa_rf, tau_rf +! +! tabulated GW-sources +! + integer :: ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t + real, allocatable :: ugwp_taulat(:), ugwp_qbolat(:) + real, allocatable :: tau_limb(:,:), days_limb(:) + real, allocatable :: uzmf_merra(:,:,:), days_merra(:), pmb127(:) + real, allocatable :: uqboe(:,:) + real, allocatable :: days_y4ddd(:), zkm127(:) + real, allocatable :: tau_qbo(:), stau_qbo(:) + integer,allocatable :: days_y4md(:) + real, allocatable :: vert_qbo(:) + +! +! limiters +! + real, parameter :: latqbo =20., widqbo=15., taurel = 21600. + integer, parameter :: kz2 = 127-7, kz1= 127-49, kz5=5 ! 64km - 18km +! + +!====================================================================== + real, parameter :: F_coriol=1 ! Coriolis effects + real, parameter :: F_nonhyd=1 ! Nonhydrostatic waves + real, parameter :: F_kds =0 ! Eddy mixing due to GW-unstable below + real, parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw + real, parameter :: iPr_turb =1./3., iPr_mol =1.95 + real, parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 + real, parameter :: khp = 0.287*rhp1 ! R/Cp/Hp + real, parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model + + contains +! +! ----------------------------------------------------------------------- +! +! init of cires_ugwp (_init) called from CCPP cap file +! +! ----------------------------------------------------------------------- + + + + subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & + lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & + pa_rf_in, tau_rf_in) +! +! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 +! + ! use netcdf + use ugwp_oro_init, only : init_oro_gws + use ugwp_conv_init, only : init_conv_gws + use ugwp_fjet_init, only : init_fjet_gws + use ugwp_okw_init, only : init_okw_gws + use ugwp_wmsdis_init, only : initsolv_wmsdis + + use ugwp_lsatdis_init, only : initsolv_lsatdis + + + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + integer, intent (in) :: logunit + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + integer, intent (in) :: jdat_gfs(8) + real, intent (in) :: ak(levs+1), bk(levs+1), pref + real, intent (in) :: dtp + real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW dims(2) !!! + real, intent (in) :: pa_rf_in, tau_rf_in + + character(len=64), intent (in) :: fn_nml2 + character(len=64), parameter :: fn_nml='input.nml' + +! character, intent (in) :: input_nml_file +! integer, parameter :: logunit = 6 + integer :: ios + logical :: exists + real :: dxsg + + integer :: ncid, iernc, vid, dimid, status + integer :: k + integer :: ddd_ugwp, curday_ugwp + real :: avqbo(6) + avqbo = [0.05, 0.1, 0.25, 0.5, 0.75, 0.95] +! + if (me == master) print *, trim (fn_nml), ' GW-namelist file ' + inquire (file =trim (fn_nml) , exist = exists) +! + if (.not. exists) then + if (me == master) & + write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' + else + open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = cires_ugwp_nml) + close (nlunit) +! + strsolver= knob_ugwp_orosolv + pa_rf = pa_rf_in + tau_rf = tau_rf_in + + curday_ugwp = jdat_gfs(1)*10000 + jdat_gfs(2)*100 +jdat_gfs(3) + call calendar_ugwp(jdat_gfs(1), jdat_gfs(2), jdat_gfs(3), ddd_ugwp) + +! write version number and namelist to log file + if (me == master) then + write (logunit, *) " ================================================================== " + write (logunit, *) "cires_ugwp_namelist_extended_v1" + write (logunit, nml = cires_ugwp_nml) + write (logunit, *) " ================================================================== " + + write (6, *) " ================================================================== " + write (6, *) "cires_ugwp_namelist_extended_v1" + write (6, nml = cires_ugwp_nml) + write (6, *) " ================================================================== " + write (6, *) "calendar_ugwp ddd_ugwp=", ddd_ugwp + write (6, *) "calendar_ugwp curday_ugwp=", curday_ugwp + write (6, *) " ================================================================== " + write (6, *) ddd_ugwp, ' jdat_gfs ddd of year ' + endif +! +! effective kxw - resolution-aware +! + dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh + kxw = pi2/knob_ugwp_lhmet +! +! kxw = pi2/dxsg +! +! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff +! + +! allocate(fcor(latr), fcor2(latr) ) +! + allocate( kvg(levs+1), ktg(levs+1) ) + allocate( krad(levs+1), kion(levs+1) ) + allocate( zkm(levs), pmb(levs) ) + allocate( rfdis(levs), rfdist(levs) ) + + allocate (vert_qbo(levs)) + +! +! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 +! + + do k=1, levs + pmb(k) = 1.e0*(ak(k) + pref*bk(k)) ! Pa -unit Pref = 1.e5, pmb = Pa + zkm(k) = -hpskm*alog(pmb(k)/pref) + enddo + vert_qbo(1:levs) = 0. + + do k=kz1, kz2 + vert_qbo(k)=1. + if (k.le.(kz1+kz5)) vert_qbo(k) = avqbo(k+1-kz1) + if (k.ge.(kz2-kz5)) vert_qbo(k) = avqbo(kz2+1-k) + if (me == master) print *, 'vertqbo', vert_qbo(k), zkm(k) + enddo + +! +! find ilaunch +! + + do k=levs, 1, -1 + if (pmb(k) .gt. knob_ugwp_palaunch ) exit + enddo + + launch_level = max(k-1, 5) ! above 5-layers from the surface + +! +! Part-1 :init_global_gwdis +! + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) +! +! Part-2 :init_SOURCES_gws +! + +! +! call init-solver for "stationary" multi-wave spectra and sub-grid oro +! + call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) +! +! call init-sources for "non-sationary" multi-wave spectra +! + do_physb_gwsrcs=.true. + + IF (do_physb_gwsrcs) THEN + + if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' + if (knob_ugwp_wvspec(4) > 0) then +! okw + call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & + knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) + if (me == master) print *, ' init_okw_gws ' + endif + + if (knob_ugwp_wvspec(3) > 0) then +! fronts + call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & + knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) + if (me == master) print *, ' init_fjet_gws ' + endif + + if (knob_ugwp_wvspec(2) > 0) then +! conv + call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) + if (me == master) & + print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + + endif + + ENDIF !IF (do_physb_gwsrcs) +! +! +! Tabulated sources +! +! goto 121 + + iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) + + if(iernc.ne.0) then + write(6,*) + write(6,*) ' cannot open file_limb_tab data-file', trim(ugwp_taufile) + write(6,*) + stop + else + + + status = nf90_inq_dimid(ncid, "lat", DimID) +! if (status /= nf90_noerr) call handle_err(status) +! + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d1y ) + + status = nf90_inq_dimid(ncid, "days", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) + if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd-tlimb ' + allocate (ugwp_taulat(ntau_d1y ), days_limb(ntau_d2t)) + allocate ( tau_limb (ntau_d1y, ntau_d2t )) + + iernc=nf90_inq_varid( ncid, 'DAYS', vid ) + iernc= nf90_get_var( ncid, vid, days_limb) + iernc=nf90_inq_varid( ncid, 'LATS', vid ) + iernc= nf90_get_var( ncid, vid, ugwp_taulat) + iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) + iernc= nf90_get_var( ncid, vid, tau_limb) + + iernc=nf90_close(ncid) + + endif +! + iernc=NF90_OPEN(trim(ugwp_qbofile), nf90_nowrite, ncid) + + if(iernc.ne.0) then + write(6,*) + write(6,*) ' cannot open qbofile data-file', trim(ugwp_qbofile) + write(6,*) + stop + else + + status = nf90_inq_dimid(ncid, "lat", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d1y ) + status = nf90_inq_dimid(ncid, "lev", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d2z) + status = nf90_inq_dimid(ncid, "days", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d3t ) + if (me == master) print *, nqbo_d1y, nqbo_d2z, nqbo_d3t, ' dims tauqbo ' + allocate (ugwp_qbolat(nqbo_d1y ), days_merra(nqbo_d3t) ) + allocate (zkm127(nqbo_d2z), pmb127(nqbo_d2z)) + allocate ( uzmf_merra (nqbo_d1y, nqbo_d2z, nqbo_d3t )) + allocate ( uqboe (nqbo_d2z, nqbo_d3t )) + allocate (days_y4ddd(nqbo_d3t), days_y4md(nqbo_d3t) ) + allocate (tau_qbo(nqbo_d3t), stau_qbo(nqbo_d3t) ) + + iernc=nf90_inq_varid( ncid, 'DAYS', vid ) + iernc= nf90_get_var( ncid, vid, days_merra) + + iernc=nf90_inq_varid( ncid, 'Y4MD', vid ) + iernc= nf90_get_var( ncid, vid, days_y4md) + + iernc=nf90_inq_varid( ncid, 'Y4DDD', vid ) + iernc= nf90_get_var( ncid, vid, days_y4ddd) + + iernc=nf90_inq_varid( ncid, 'LATS', vid ) + iernc= nf90_get_var( ncid, vid, ugwp_qbolat) + + iernc=nf90_inq_varid( ncid, 'LEVS', vid ) + iernc= nf90_get_var( ncid, vid, zkm127) + + + iernc=nf90_inq_varid( ncid, 'UQBO', vid ) + iernc= nf90_get_var( ncid, vid, uzmf_merra) + + iernc=nf90_inq_varid( ncid, 'TAUQBO', vid ) + iernc= nf90_get_var( ncid, vid, tau_qbo) + + iernc=nf90_inq_varid( ncid, 'STAUQBO', vid ) + iernc= nf90_get_var( ncid, vid, stau_qbo) + iernc=nf90_inq_varid( ncid, 'UQBOE', vid ) + iernc= nf90_get_var( ncid, vid, uqboe) + iernc=nf90_close(ncid) + endif + + if (me == master) then + print * + print *, ' ugwp_tabulated files input ' + print *, ' ugwp_taulat ', ugwp_taulat + print *, ' days ', days_limb + print *, ' TAU-limb ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 + print *, ' TAU-qbo ', maxval(stau_qbo)*1.e3, minval(stau_qbo)*1.e3 + print *, ' YMD-qbo ', maxval(days_y4md), minval(days_y4md) + print *, ' YDDD-qbo ', maxval(days_y4ddd), minval(days_y4ddd) + print *, ' uzmf_merra ',maxval(uzmf_merra), minval(uzmf_merra) + print *, ' uEq_merra ',maxval(uqboe), minval(uqboe) + print * + endif + +! +121 continue +! endif ! tabulated sources SABER/HIRDLS/QBO + +!====================== +! Part-3 :init_SOLVERS +! ===================== +! +! call init-solvers for "broad" non-stationary multi-wave spectra +! + if (knob_ugwp_solver==1) then +! + call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) + endif + if (knob_ugwp_solver==2) then +! +! re-assign from namelists +! + nslope = knob_ugwp_nslope ! the GW sprctral slope at small-m + lzstar = knob_ugwp_lzstar + lzmax = knob_ugwp_lzmax + lzmin = knob_ugwp_lzmin + lhmet = knob_ugwp_lhmet + tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 + tau_min =knob_ugwp_taumin ! min of GW MF 0.25 mPa + ilaunch = launch_level + kxw = pi2/lhmet + call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) + endif +! +! other solvers not yet tested for fv3gfs +! +!< if (knob_ugwp_solver==3) call init_dspdis +!< if (knob_ugwp_solver==4) call init_adodis +! + +!====================== + module_is_initialized = .true. + if (me == master) print *, ' CIRES-ugwp-V1 is initialized ', module_is_initialized + + end subroutine cires_ugwp_init_v1 + + +!============================================= + + + subroutine cires_ugwp_advance +!----------------------------------------------------------------------- +! +! options for the day-to-day variable sources/spectra + diagnostics +! for stochastic "triggers" +! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields +! or use for stochastic GWP-sources "memory" +!----------------------------------------------------------------------- + implicit none +! +! update sources +! a) physics-based triggers for multi-wave +! b) stochastic-based spectra and amplitudes +! c) use "memory" on GW-spectra from previous time-step +! d) update "background" GW dissipation as needed +! + end subroutine cires_ugwp_advance + +! +! ----------------------------------------------------------------------- +! finalize of cires_ugwp (_finalize) +! ----------------------------------------------------------------------- + + + subroutine cires_ugwp_finalize +! +! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" +! before "end" of the FV3GFS +! + implicit none +! +! deallocate arrays employed in: +! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! + deallocate( kvg, ktg ) + deallocate( krad, kion ) + deallocate( zkm, pmb ) + deallocate( rfdis, rfdist) + deallocate(ugwp_taulat, ugwp_qbolat) + deallocate(tau_limb, uzmf_merra) + deallocate(days_limb, days_merra, pmb127) + + end subroutine cires_ugwp_finalize + +! +! +! +! + subroutine calendar_ugwp(yr, mm, dd, ddd_ugwp) +! +! computes day of year to get tau_limb forcing written with 1-day precision +! + implicit none + integer, intent(in) :: yr, mm, dd + integer :: ddd_ugwp + + integer :: iw3jdn + integer :: jd1, jddd + jd1 = iw3jdn(yr,1,1) + jddd = iw3jdn(yr,mm,dd) + ddd_ugwp = jddd-jd1+1 + + end subroutine calendar_ugwp + + + subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau, & + j1_qbo,j2_qbo, w1_j1qbo, w2_j2qbo, dexp_latqbo ) + + implicit none +! +! ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t +! ugwp_taulat(:), ugwp_qbolat(:), ugwp_merlat(:) +! + integer :: npts, me, master + integer, dimension(npts) :: j1_tau,j2_tau, j1_qbo, j2_qbo + real , dimension(npts) :: dlat, w1_j1tau, w2_j2tau, w1_j1qbo, w2_j2qbo + real , dimension(npts) :: dexp_latqbo + real :: widqbo2, xabs +! + integer i,j, j1, j2 +! +! weights for tau_limb w1_j1tau, w2_j2tau +! + do j=1,npts + j2_qbo(j) = nqbo_d1y + do i=1, nqbo_d1y + if (dlat(j) < ugwp_qbolat(i)) then + j2_qbo(j) = i + exit + endif + enddo + + + j2_qbo(j) = min(j2_qbo(j),nqbo_d1y) + j1_qbo(j) = max(j2_qbo(j)-1,1) + + if (j1_qbo(j) /= j2_qbo(j) ) then + w2_j2qbo(j) = (dlat(j) - ugwp_qbolat(j1_qbo(j))) & + / (ugwp_qbolat(j2_qbo(j))-ugwp_qbolat(j1_qbo(j))) + + else + w2_j2qbo(j) = 1.0 + endif + w1_j1qbo(j) = 1.0 - w2_j2qbo(j) + +! + enddo +! +! weights for tau_limb w1_j1tau, w2_j2tau +! + do j=1,npts + j2_tau(j) = ntau_d1y + do i=1,ntau_d1y + if (dlat(j) < ugwp_taulat(i)) then + j2_tau(j) = i + exit + endif + enddo + + + j2_tau(j) = min(j2_tau(j),ntau_d1y) + j1_tau(j) = max(j2_tau(j)-1,1) + + if (j1_tau(j) /= j2_tau(j) ) then + w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & + / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) + + else + w2_j2tau(j) = 1.0 + endif + w1_j1tau(j) = 1.0 - w2_j2tau(j) + + enddo + widqbo2 =1./widqbo/widqbo + do j=1,npts + dexp_latqbo(j) =0. + xabs =abs(dlat(j)) + if (xabs .le. latqbo) then + dexp_latqbo(j) = exp(-xabs*xabs*widqbo2) + if (xabs .le. 4.0 ) dexp_latqbo(j) =1. +! print *, ' indx_ugwp dexp=', dexp_latqbo(j), nint(dlat(j)) + endif + enddo + + if (me == master ) then +222 format( 2x, 'vay-wqbo', I4, 5(2x, F10.3)) +223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) + print *, 'vay_indx_ugwp ', size(dlat), ' npts ', npts + do j=1,npts + j1 = j1_tau(j) + j2 = j2_tau(j) + write(6,223) j, ugwp_taulat(j1), dlat(j), ugwp_taulat(j2), w2_j2tau(j), w1_j1tau(j) + enddo + print * + do j=1,npts + j1 = j1_qbo(j) + j2 = j2_qbo(j) + write(6,222) j, ugwp_qbolat(j1), dlat(j), ugwp_qbolat(j2), w2_j2qbo(j), w1_j1qbo(j) + enddo + endif + end subroutine cires_indx_ugwp + +! + end module cires_ugwp_module_v1 + diff --git a/physics/cires_ugwp_ngw_utils.F90 b/physics/cires_ugwp_ngw_utils.F90 new file mode 100644 index 000000000..4b2a19884 --- /dev/null +++ b/physics/cires_ugwp_ngw_utils.F90 @@ -0,0 +1,73 @@ +module cires_ugwp_ngw_utils + + +contains + + + subroutine tau_limb_advance(me, master, im, levs, ddd, curdate, & + j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + + + + use machine, only : kind_phys + + use cires_ugwp_module_v1, only : ntau_d1y, ntau_d2t + use cires_ugwp_module_v1, only : ugwp_taulat, days_limb, tau_limb + +! use cires_ugwp_module, only : ugwp_qbolat, days_merra, pmb127, days_y4md, days_y4ddd +! use cires_ugwp_module, only : tau_qbo, stau_qbo, uqboe, u2 => uzmf_merra + + implicit none + + integer, intent(in) :: me, master, im, levs, ddd, curdate, kdt + integer, intent(in), dimension(im) :: j1_tau, j2_tau + + real , intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau + + real, intent(out) :: tau_sat(im) + + integer :: i, j1, j2, k, it1, it2, iday + real :: tem, tx1, tx2, w1, w2, day2, day1, ddx + integer :: yr1, yr2 +! + integer :: iqbo1=1 +! + + + + it1 = 2 + do iday=1, ntau_d2t + if (float(ddd) .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + stop + endif + w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) + tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) + tau_sat(i) = tx1*w1 + w2*tx2 + enddo + + if (me == master ) then + print*, maxval(tau_limb), minval(tau_limb), ' tau_limb ' + print*, ntau_d2t + print*, days_limb(1) , days_limb(ntau_d2t) , ddd, ' days-taulimb ' + print*, 'curdate ', curdate + print*, maxval(tau_sat), minval(tau_sat), ' tau_sat_fv3 ' + endif + return + + end subroutine tau_limb_advance + +end module cires_ugwp_ngw_utils diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 new file mode 100644 index 000000000..1a6cedcb3 --- /dev/null +++ b/physics/cires_ugwp_orolm97_v1.F90 @@ -0,0 +1,985 @@ +module cires_ugwp_orolm97_v1 + + +contains + + + + subroutine gwdps_oro_v1(im, km, imx, do_tofd, & + pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & + prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & + oc, oa4, clx4, theta, sigma, gamma, elvmaxd, sgh30, & + dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & + cdmbgwd, me, master, rdxzb, & + zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & + dudt_mtb, dudt_ogw, dudt_tms) +!---------------------------------------- +! ugwp_v1: gwdps_oro_v1 following recent updates of Lott & Miller 1997 +! eventually will be replaced with more "advanced"LLWB +! and multi-wave solver that produce competitive FV3GFS-skills +! +! computation of kref for ogw + coorde diagnostics +! all constants/parameters inside cires_ugwp_initialize.f90 +!---------------------------------------- + + use machine , only : kind_phys + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2, & + pi, rad_to_deg, deg_to_rad, pi2, & + rdi, gor, grcp, gocp, fv, gr2, & + bnv2min, dw2min, velmin, arad + + use ugwp_oro_init, only : rimin, ric, efmin, efmax , & + hpmax, hpmin, sigfaci => sigfac , & + dpmin, minwnd, hminmt, hncrit , & + rlolev, gmax, veleps, factop , & + frc, ce, ceofrc, frmax, cg, & + fdir, mdir, nwdir, & + cdmb, cleff, fcrit_gfs, fcrit_mtb, & + n_tofd, ze_tofd, ztop_tofd + + use cires_ugwp_module, only : kxw, max_kdis, max_axyz + + use cires_orowam2017, only : oro_wam_2017 + + use cires_vert_orodis, only : ugwp_tofd1d + + +! use sso_coorde, only : pgwd, pgwd4 +!---------------------------------------- + implicit none + real(kind=kind_phys), parameter :: pgwd=1, pgwd4= pgwd + real(kind=kind_phys), parameter :: sigfac = 3, sigfacs = 0.5 + character(len=8) :: strsolver='pss-1986' ! current operational solver or 'wam-2017' + real(kind=kind_phys) :: gammin = 0.00999999 + real(kind=kind_phys), parameter :: nhilmax = 25. + real(kind=kind_phys), parameter :: sso_min = 3000. + logical, parameter :: do_adjoro = .false. +!---------------------------------------- + + integer, intent(in) :: im, km, imx, kdt + integer, intent(in) :: me, master + logical, intent(in) :: do_tofd + + + + integer, intent(in) :: kpbl(im) ! index for the pbl top layer! + real(kind=kind_phys), intent(in) :: dtp ! time step + real(kind=kind_phys), intent(in) :: cdmbgwd(2) + + real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & + clx4(im,4), theta(im), sigma(im), & + gamma(im), elvmaxd(im) + + real(kind=kind_phys), intent(in) :: sgh30(im) + real(kind=kind_phys), intent(in), dimension(im,km) :: & + u1, v1, t1, q1,del, prsl, prslk, zmet + + real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti + real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) + real(kind=kind_phys), intent(in) :: sparea(im) + +! +!output -phys-tend + real(kind=kind_phys),dimension(im,km),intent(out) :: & + pdvdt, pdudt, pkdis, pdtdt +! output - diag-coorde + real(kind=kind_phys),dimension(im,km),intent(out) :: & + dudt_mtb, dudt_ogw, dudt_tms +! + real(kind=kind_phys),dimension(im) :: rdxzb, zmtb, zogw , & + tau_ogw, tau_mtb, tau_tofd, dusfc, dvsfc + +! +!--------------------------------------------------------------------- +! # of permissible sub-grid orography hills for "any" resolution < 25 +! correction for "elliptical" hills based on shilmin-area =sgrid/25 +! 4.*gamma*b_ell*b_ell >= shilmin +! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min +! gamma_min = 1/4*shilmin/sso_min/sso_min +!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 +! 192: cdmbgwd = 0.5, 2.5 +! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km +! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin +!--------------------------------------------------------------------- +! +! locals SSO +! + real(kind=kind_phys) :: vsigma(im), vgamma(im) + + real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax +! real(kind=kind_phys) :: arhills(im) ! not used why do we need? + real(kind=kind_phys) :: xlingfs + +! +! locals mean flow ...etc +! + real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro + real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco +!mtb + real(kind=kind_phys), dimension(im) :: oa, clx , elvmax, wk + real(kind=kind_phys), dimension(im) :: pe, ek, up + + real(kind=kind_phys), dimension(im,km) :: db, ang, uds + + real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr + real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 + real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem +! +! tofd +! some constants now in "use ugwp_oro_init" + "use ugwp_common" +! +!================== + real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf + real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 + real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 + real(kind=kind_phys), dimension(km) :: up1, vp1, zpm + + real(kind=kind_phys),dimension(im, km) :: axtms, aytms +! +! ogw +! + logical icrilv(im) +! + real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & + roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 +! + real(kind=kind_phys) :: taup(im,km+1), taud(im,km) + real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis + + integer, dimension(im) :: kref, idxzb, ipt, kreflm, iwklm, iwk, izlow + +! +!check what we need +! + real(kind=kind_phys) :: bnv, fr, ri_gw, brvf + real(kind=kind_phys) :: tem, tem1, tem2, temc, temv + real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 + real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv + real(kind=kind_phys) :: scork, rscor, hd, fro, sira + real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk + + real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge + + real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 + real(kind=kind_phys) :: belps, aelps, nhills, selps +! +! various integers +! + integer :: kmm1, kmm2, lcap, lcapp1 + integer :: npt, kbps, kbpsp1,kbpsm1 + integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll + integer :: k_mtb, k_zlow, ktrial, klevm1 + integer :: i, j, k +! + rcpdt = 1.0 / (cpd*dtp) + grav2 = grav + grav +! +! mtb-blocking sigma_min and dxres => cires_initialize +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + + dxres = pi2*arad/float(imx) + hdxres = 0.5*dxres +! shilmin = sgrmin/nhilmax ! not used - moorthi + +! gammin = min(sso_min/dsmax, 1.) ! moorthi - with this results are not reproducible + gammin = min(sso_min/dxres, 1.) ! moorthi + +! sigmin = 2.*hpmin/dsmax !dxres ! moorthi - this will not reproduce + sigmin = 2.*hpmin/dxres !dxres + +! if (kdt == 1) then +! print *, sgrmax, sgrmin , ' min-max sparea ' +! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax +! print *, 'dxres/dsmax ', dxres, dsmax +! print *, ' shilmin gammin ', shilmin, gammin +! endif + + kxridge = float(imx)/arad * cdmbgwd(2) + + if (me == master .and. kdt == 1) then + print *, ' gwdps_v0 kxridge ', kxridge + print *, ' gwdps_v0 scale2 ', cdmbgwd(2) + print *, ' gwdps_v0 imx ', imx + print *, ' gwdps_v0 gam_min ', gammin + print *, ' gwdps_v0 sso_min ', sso_min + endif + + do i=1,im + idxzb(i) = 0 + zmtb(i) = 0.0 + zogw(i) = 0.0 + rdxzb(i) = 0.0 + tau_ogw(i) = 0.0 + tau_mtb(i) = 0.0 + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + tau_tofd(i) = 0.0 +! + ipt(i) = 0 +! + enddo + + do k=1,km + do i=1,im + pdvdt(i,k) = 0.0 + pdudt(i,k) = 0.0 + pdtdt(i,k) = 0.0 + pkdis(i,k) = 0.0 + dudt_mtb(i,k) = 0.0 + dudt_ogw(i,k) = 0.0 + dudt_tms(i,k) = 0.0 + enddo + enddo + +! ---- for lm and gwd calculation points +!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 +!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) +!---- for lm and gwd calculation points + + + npt = 0 + + do i = 1,im + if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then + npt = npt + 1 + ipt(npt) = i + endif + enddo + + if (npt == 0) then +! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt +! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin + return ! no gwd/mb calculation done + endif +!======================================================== + +! + if (do_adjoro ) then + + do i = 1,im +! arhills(i) = 1.0 +! + sigres = max(sigmin, sigma(i)) +! if (sigma(i) < sigmin) sigma(i)= sigmin + dxres = sqrt(sparea(i)) + if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres + aelps = min(2.*hprime(i)/sigres, 0.5*dxres) + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) +! +! small-scale "turbulent" oro-scales < sso_min +! + if( aelps < sso_min ) then + +! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm +! + aelps = sso_min + if (belps < sso_min ) then + gamma(i) = 1.0 + belps = aelps*gamma(i) + else + gamma(i) = min(aelps/belps, 1.0) + endif + + sigma(i) = 2.*hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + + endif + + selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill + nhills = min(nhilmax, sparea(i)/selps) +! arhills(i) = max(nhills, 1.0) + +!333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) +! if (kdt==1 ) +! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, +! & belps*1.e-3, sigma(i),gamma(i) + + + enddo + endif !(do_adjoro ) + + + + do i=1,npt + iwklm(i) = 2 + idxzb(i) = 0 + kreflm(i) = 0 + enddo + + do k=1,km + do i=1,im + db(i,k) = 0.0 + ang(i,k) = 0.0 + uds(i,k) = 0.0 + enddo + enddo + + kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 + lcap = km ; lcapp1 = lcap + 1 + + cdmb4 = 0.25*cdmb + + do i = 1, npt + j = ipt(i) + elvmax(j) = min (elvmaxd(j)*0. + sigfac * hprime(j), hncrit) + izlow(i) = 1 ! surface-level + enddo +! + do k = 1, kmm1 + do i = 1, npt + j = ipt(i) + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) +! if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) +! & iwklm(i) = max(iwklm(i), k+1 ) + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) iwklm(i) = max(iwklm(i), k+1 ) + if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) + + enddo + enddo +! + do k = 1,km + do i =1,npt + j = ipt(i) + vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) + vtk(i,k) = vtj(i,k) / prslk(j,k) + ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels + taup(i,k) = 0.0 + enddo + enddo +! +! check ri_n or ri_mf computation +! + do k = 1,kmm1 + do i =1,npt + j = ipt(i) + rdz = 1. / (zmet(j,k+1) - zmet(j,k)) + tem1 = u1(j,k) - u1(j,k+1) + tem2 = v1(j,k) - v1(j,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz +! ti = 2.0 / (t1(j,k)+t1(j,k+1)) +! bvf2 = grav*(gocp+rdz*(vtj(i,k+1)-vtj(i,k)))* ti +! ri_n(i,k) = max(bvf2/shr2,rimin) ! richardson number +! + bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! +! add here computation for ktur and ogw-dissipation fro ve-gfs +! + enddo + enddo + k = 1 + do i = 1, npt + bnv2(i,k) = bnv2(i,k+1) + enddo +! +! level iwklm => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) +! + do i = 1, npt + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == iwklm(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,iwklm(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,iwklm(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + pe (i) = 0.0 + ek (i) = 0.0 + bnv2bar(i) = 0.0 + enddo +! + do i = 1, npt + k_zlow = izlow(i) + if (k_zlow == iwklm(i)) k_zlow = 1 + do k = k_zlow, iwklm(i)-1 ! kreflm(i)= iwklm(i)-1 + j = ipt(i) ! laye-aver rho, u, v + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) ! trial mean u below + vbar(i) = vbar(i) + rdelks * v1(j,k) ! trial mean v below + roll(i) = roll(i) + rdelks * ro(i,k) ! trial mean ro below +! + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo + enddo +! + do i = 1, npt + j = ipt(i) +! +! integrate from ztoph = sigfac*hprime down to zblk if exists +! find ph_blk, dz_blk like in LM-97 and ifs +! + ph_blk =0. + do k = iwklm(i), 1, -1 + phiang = atan2(v1(j,k),u1(j,k))*rad_to_deg + ang(i,k) = ( theta(j) - phiang ) + if ( ang(i,k) > 90. ) ang(i,k) = ang(i,k) - 180. + if ( ang(i,k) < -90. ) ang(i,k) = ang(i,k) + 180. + ang(i,k) = ang(i,k) * deg_to_rad + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +! + if (idxzb(i) == 0 ) then + dz_blk = zmeti(j,k+1) - zmeti(j,k) + pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk + + up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) + ek(i) = 0.5 * up(i) * up(i) + + ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) + +! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs +! if ( pe(i) >= ek(i) ) then + if ( ph_blk >= fcrit_gfs ) then + idxzb(i) = k + zmtb (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif + + endif + enddo +! +! alternative expression: zmtb = max(heff*(1. -fcrit_gfs/fr), 0) +! fcrit_gfs/fr +! + goto 788 + + bnv = sqrt( bnv2bar(i) ) + heff = 2.*min(hprime(j),hpmax) + zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) + ulow(i) = sqrt(max(zw2,dw2min)) + fr = heff*bnv/ulow(i) + zw1 = max(heff*(1. -fcrit_gfs/fr), 0.0) + zw2 = zmet(j,2) + if (fr > fcrit_gfs .and. zw1 > zw2 ) then + do k=2, kmm1 + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) + if (zw1 <= zmetp .and. zw1 >= zmetk) exit + enddo + idxzb(i) = k + zmtb (j) = zmet(j, k) + else + zmtb (j) = 0. + idxzb(i) = 0 + endif + +788 continue +! +! --- the drag for mtn blocked flow +! + if ( idxzb(i) > 0 ) then + +! (4.16)-ifs + gam2 = gamma(j)*gamma(j) + bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 + cgam = 0.48*gamma(j) + 0.30*gam2 + + do k = idxzb(i)-1, 1, -1 + zlen = sqrt( (zmtb(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 +! +! cos =1 sin =0 => 1/r= gam zr = 2.-gam +! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam +! + rdem = cosang2 + gam2 * sinang2 + rnom = cosang2*gam2 + sinang2 +! +! metoffice dec 2010 +! correction of h. wells & a. zadra for the +! aspect ratio of the hill seen by mean flow +! (1/r , r-inverse below: 2-r) + + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + + sigres = max(sigmin, sigma(j)) + if (hprime(j)/sigres > dxres) sigres = hprime(j)/dxres + mtbridge = zr * sigres*zlen / hprime(j) +! (4.15)-ifs +! dbtmp = cdmb4 * mtbridge * & +! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) +! (4.16)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) + db(i,k)= dbtmp * uds(i,k) + enddo +! + endif + enddo +!............................. +!............................. +! end mtn blocking section +!............................. +!............................. +! +!--- orographic gravity wave drag section +! +! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 +! inside "cires_ugwp_initialize.f90" now +! + kmpbl = km / 2 + iwk(1:npt) = 2 +! +! meto/UK-scheme: +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw +! + do k=3,kmpbl + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb + +!=============================================================== +! lev=111 t=311.749 hkm=0.430522 ps-p(iwk)=52.8958 +! below "hprime" - source of ogws and below zblk !!! +! 27 2 kpbl ~ 1-2 km < hprime +!=============================================================== + enddo + enddo +! +! iwk - adhoc gfs-parameter to select ogw-launch level between +! level ~0.4-0.5 km from surface or/and pbl-top +! in ugwp-v1: options to modify as htop ~ (2-3)*hprime > zmtb +! in ugwp-v0 we ensured that : zogw > zmtb +! + + kbps = 1 + kmps = km + k_mtb = 1 + do i=1,npt + j = ipt(i) + k_mtb = max(1, idxzb(i)) + + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else ???? + kref(i) = max(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime + + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above zmtb + kbps = max(kbps, kref(i)) + kmps = min(kmps, kref(i)) +! + delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + bnv2bar(i)= 0.0 + enddo +! + kbpsp1 = kbps + 1 + kbpsm1 = kbps - 1 + k_mtb = 1 +! + do i = 1,npt + k_mtb = max(1, idxzb(i)) + do k = k_mtb,kbps !kbps = max(kref) ;kmps= min(kref) + if (k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref + vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref + roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo + enddo +! +! orographic asymmetry parameter (oa), and (clx) + do i = 1,npt + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) + clx(i) = clx4(j,mod(nwd-1,4)+1) + enddo +! + do i = 1,npt + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control vector + ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) + xn(i) = ubar(i) / ulow(i) + yn(i) = vbar(i) / ulow(i) + enddo +! + do k = 1, kmm1 + do i = 1,npt + j = ipt(i) + velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) + + enddo + enddo +! +!------------------ +! v0: incorporates latest modifications for kxridge and heff/hsat +! and taulin for fr <=fcrit_gfs +! and concept of "clipped" hill if zmtb > 0. to make +! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data +! it is still used the "single-orowave"-approach along ulow-upwind +! +! in contrast to the 2-orthogonal wave (2otw) schemes of ifs/meto/e-canada +! 2otw scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b +! with 2-stresses: taub_a & taub_b as of Phillips (1984) +!------------------ + taub(:) = 0. ; taulin(:)= 0. + do i = 1,npt + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + + if( zmtb(j) > 0.) heff = max(sigfac*heff-zmtb(j), 0.)/sigfac + if (heff <= 0) cycle + + hsat = fcrit_gfs*ulow(i)/bnv + heff = min(heff, hsat) + + fr = min(bnv * heff /ulow(i), frmax) +! + efact = (oa(i) + 2.) ** (ceofrc*fr) + efact = min( max(efact,efmin), efmax ) +! + coefm = (1. + clx(i)) ** (oa(i)+1.) +! + xlinv(i) = coefm * cleff ! effective kxw for lin-wave + xlingfs = coefm * cleff +! + tem = fr * fr * oc(j) + gfobnv = gmax * tem / ((tem + cg)*bnv) +! +!new specification of xlinv(i) & taulin(i) + + sigres = max(sigmin, sigma(j)) + if (heff/sigres > hdxres) sigres = heff/hdxres + inv_b2eff = 0.5*sigres/heff + kxridge = 1.0 / sqrt(sparea(j)) + xlinv(i) = xlingfs !or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge + taulin(i) = 0.5*roll(i)*xlinv(i)*bnv*ulow(i)*heff*heff*pgwd4 + + if ( fr > fcrit_gfs ) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact ! nonlinear flux tau0...xlinv(i) +! + else +! taub(i) = taulin(i) ! linear flux for fr <= fcrit_gfs + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact +! + endif +! +! + k = max(1, kref(i)-1) + tem = max(velco(i,k)*velco(i,k), dw2min) + scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level +! +! diagnostics for zogw > zmtb +! + zogw(j) = zmeti(j, kref(i) ) + enddo +! +!----set up bottom values of stress +! + do k = 1, kbps + do i = 1,npt + if (k <= kref(i)) taup(i,k) = taub(i) + enddo + enddo + + if (strsolver == 'pss-1986') then + +!====================================================== +! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" +! in v1-orogw linsatdis of "wam-2017" +! with llwb-mechanism for +! rotational/non-hydrostat ogws important for +! highres-fv3gfs with dx < 10 km +!====================================================== + + do k = kmps, kmm1 ! vertical level loop from min(kref) + kp1 = k + 1 + do i = 1, npt +! + if (k >= kref(i)) then + icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) + endif + enddo +! + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + temv = 1.0 / max(velco(i,k), velmin) +! + if (oa(i) > 0. .and. kp1 < kref(i)) then +! + scork = bnv2(i,k) * temv * temv + rscor = min(1.0, scork / scor(i)) + scor(i) = scork + else + rscor = 1. + endif +! + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface +! tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*velco(i,k)*0.5 + + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*0.5 & + * max(velco(i,k), velmin) + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv +! +! rim is the "wave"-richardson number by palmer,shutts, swinbank 1986 +! + + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check stability to employ the 'dynamical saturation hypothesis' +! of palmer,shutts, swinbank 1986 +! + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf + taup(i,kp1) = tem1 * hd * hd + else + taup(i,kp1) = taup(i,k) * rscor + endif +! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif + endif + enddo + enddo +! +! zero momentum deposition at the top model layer +! + taup(1:npt,km+1) = taup(1:npt,km) +! +! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud +! + do k = 1,km + do i = 1,npt + taud(i,k) = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) + enddo + enddo + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!------if the gravity wave drag would force a critical line in the +!------layers below sigma=rlolev during the next deltim timestep, +!------then only apply drag until that critical line is reached. +! empirical implementation of the llwb-mechanism: lower level wave breaking +! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb +! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws +!2019: this option limits sensitivity of taux/tauy to increase/decrease of taub +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then + + if(taud(i,k) /= 0.) then + tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +! dtfac(i) = 1.0 + endif + endif + enddo + enddo +! +!--------------------------- orogw-solver of gfs pss-1986 +! + else +! +!-----------Unified orogw-solver of wam2017 +! +! sigres = max(sigmin, sigma(j)) +! if (heff/sigres.gt.dxres) sigres=heff/dxres +! inv_b2eff = 0.5*sigres/heff +! xlinv(i) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./lridge + + dtfac(:) = 1.0 + + call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) + + endif ! oro_wam_2017 - linsatdis-solver of wam-2017 +! +!---- above orogw-solver of wam2017 +! +! tofd as in beljaars-2004 +! +! --------------------------- + if( do_tofd ) then + axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 + if ( kdt == 1 .and. me == 0) then + print *, 'vay do_tofd from surface to ', ztop_tofd + endif + do i = 1,npt + j = ipt(i) + zpbl = zmet( j, kpbl(j) ) + + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso + + zsurf = zmeti(j,1) + do k=1,km + zpm(k) = zmet(j,k) + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo + + call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,km + axtms(j,k) = utofd1(k) + aytms(j,k) = vtofd1(k) +! +! add tofd to gw-tendencies +! + pdvdt(j,k) = pdvdt(j,k) + aytms(j,k) + pdudt(j,k) = pdudt(j,k) + axtms(j,k) + enddo +!2018-diag + tau_tofd(j) = sum( utofd1(1:km)* del(j,1:km)) + enddo + endif ! do_tofd + +!-------------------------------------------- +! combine oro-drag effects MB +TOFD + OGWs +!-------------------------------------------- +! + diag-3d + + dudt_tms = axtms + tau_ogw = 0. + tau_mtb = 0. + + do k = 1,km + do i = 1,npt + j = ipt(i) +! + eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) +! + if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then +! +! if blocking layers -- no ogws +! + dbim = db(i,k) / (1.+db(i,k)*dtp) + pdvdt(j,k) = - dbim * v1(j,k) +pdvdt(j,k) + pdudt(j,k) = - dbim * u1(j,k) +pdudt(j,k) + eng1 = eng0*(1.0-dbim*dtp)*(1.-dbim*dtp) + + dusfc(j) = dusfc(j) - dbim * u1(j,k) * del(j,k) + dvsfc(j) = dvsfc(j) - dbim * v1(j,k) * del(j,k) +!2018-diag + dudt_mtb(j,k) = -dbim * u1(j,k) + tau_mtb(j) = tau_mtb(j) + dudt_mtb(j,k)* del(j,k) + + else +! +! ogw-s above blocking height +! + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) * pgwd + dtauy = taud(i,k) * yn(i) * pgwd + + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) + + unew = u1(j,k) + dtaux*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + dtauy*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) +! + dusfc(j) = dusfc(j) + dtaux * del(j,k) + dvsfc(j) = dvsfc(j) + dtauy * del(j,k) +!2018-diag + dudt_ogw(j,k) = dtaux + tau_ogw(j) = tau_ogw(j) +dtaux*del(j,k) + endif +! +! local energy deposition sso-heat +! + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + enddo + enddo +! dusfc w/o tofd sign as in the era-i, merra and cfsr + do i = 1,npt + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) + tau_mtb(j) = -rgrav * tau_mtb(j) + tau_ogw(j) = -rgrav * tau_ogw(j) + tau_tofd(j) = -rgrav * tau_tofd(j) + enddo + + return + + +!============ debug ------------------------------------------------ + if (kdt <= 2 .and. me == 0) then + print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' +! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' + print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' + print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' +! print *, maxval(tau_tofd), ' tau_tofd ' +! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' +! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' + if (maxval(abs(pdudt))*86400. > 100.) then + + print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' + print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' + print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' + print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' + print *, maxval(del), minval(del), ' del gwdps-v0 ' + print *, maxval(zmet),minval(zmet), 'zmet' + print *, maxval(zmeti),minval(zmeti), 'zmeti' + print *, maxval(prsi), minval(prsi), ' prsi ' + print *, maxval(prsl), minval(prsl), ' prsl ' + print *, maxval(ro), minval(ro), ' ro-dens ' + print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' + print * + do i =1, npt + j= ipt(i) + print *,zogw(j)/hprime(j), zmtb(j)/hprime(j), & + zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) +! +!.................................................................... +! +! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m +! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km +! we must exclude blocking by small ridges +! vay-kref < iblk zogw-lev 15 block-level: 39 +! +! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters +! max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), minwnd) +! max(dw2,dw2min) * rdz * rdz +! ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) +! tem = max(velco(i,k)*velco(i,k), 0.1) +! temv = 1.0 / max(velco(i,k), 0.01) +! & * max(velco(i,k),0.01) +!.................................................................... + enddo + print * + stop + endif + endif + +!cires_ugwp_solv2_v1.f90 + return + end subroutine gwdps_oro_v1 + + +end module cires_ugwp_orolm97_v1 diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 new file mode 100644 index 000000000..ec2ec7bf2 --- /dev/null +++ b/physics/cires_ugwp_solv2_v1_mod.F90 @@ -0,0 +1,810 @@ +module cires_ugwp_solv2_v1_mod + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- + subroutine cires_ugwp_solv2_v1(im, levs, dtp , & + tm , um, vm, qm, prsl, prsi, zmet, zmeti, & + prslk, xlatd, sinlat, coslat, & + pdudt, pdvdt, pdtdt, dked, tauabs, wrms, trms, & + tau_ngw, mpi_id, master, kdt) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! -------------------------------------------------------------------------------- +! + + use machine, only : kind_phys + + use cires_ugwp_module,only : krad, kvg, kion, ktg + + use cires_ugwp_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min +! + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +!23456 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + + real ,intent(in) :: dtp ! model time step + real ,intent(in) :: vm(im,levs) ! meridional wind + real ,intent(in) :: um(im,levs) ! zonal wind + real ,intent(in) :: qm(im,levs) ! spec. humidity + real ,intent(in) :: tm(im,levs) ! kinetic temperature + + real ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real ,intent(in) :: prsi(im,levs+1) ! interface pressure + real ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real ,intent(in) :: xlatd(im) ! lat was in radians, now with xlat_d in degrees + real ,intent(in) :: sinlat(im) + real ,intent(in) :: coslat(im) + real ,intent(in) :: tau_ngw(im) + + integer, intent(in):: mpi_id, master, kdt +! +! +! out-gw effects +! + real ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp + real ,intent(out) :: dked(im,levs) ! gw-eddy diffusion +! +! GW diagnostics => next move it to "module_gw_diag" +! + real ,intent(out) :: tauabs(im,levs) ! + real ,intent(out) :: wrms(im,levs) ! + real ,intent(out) :: trms(im,levs) ! + + real :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real :: fpu(nazd, levs+1) ! az-momentum flux + real :: ui(nazd, levs+1) ! azimuthal wind + + real :: fden_bn(levs+1) ! density/brent + real :: flux_z(nwav,levs+1) + real :: flux(nwav, nazd) +! +! =============================================================================================== +! ilaunch:levs ....... MOORTHI's improvements +! all computations of GW-effects include interface layers from ilaunch+1 to levs +1 +! at k=levs+1, extrapolation of MF-state has been made, "ideally" all spectral modes should +! be absorbed; 2-options for this "ideal" requirement +! a) properly truncate GW-spectra ; b) dissipate all GW-energy in the top layers ( GW-sponge) +!===================================================================================================== +! + real :: bn(levs+1) ! interface BV-frequency + real :: bn2(levs+1) ! interface BV*BV-frequency + real :: rhoint(levs+1) ! interface density + real :: uint(levs+1) ! interface zonal wind + real :: vint(levs+1) ! meridional wind + + real :: irhodz_mid(levs), dzdt(levs+1), bnk(levs+1), rhobnk(levs+1) + + real :: v_zmet(levs+1) + real :: vueff(levs+1) + real :: dfdz_v(nazd, levs) ! axj = -df*rho/dz directional momentum deposition + + + real :: suprf(levs+1) ! RF-super linear dissipation + + real, dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet + real, dimension(levs+1) :: aprsi, azmeti + + real :: wrk3(levs) + real, dimension(levs) :: uold, vold, told, unew, vnew, tnew + real, dimension(levs) :: dktur, rho, rhomid, adif, cdif + + real :: rdci(nwav), rci(nwav) + real :: wave_act(nwav, nazd) ! active waves at given vert-level + real :: ul(nazd) ! velocity in azimuthal direction at launch level + real :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real :: c2f2, cf1 + + + real :: flux_norm ! norm-factor + real :: taub_src, rho_src +! +! scalars +! + real :: zthm, dtau, cgz, ucrit_maxdc + real :: vm_zflx_mode, vc_zflx_mode + real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real :: ucrit_max + real :: pwrms, ptrms + real :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real :: zatmp, fluxs, zdep, ze1, ze2 + +! + real :: zdelp, zdelm, taud_min + real :: tvc, tvm, ptc, ptm + real :: umfp, umfm, umfc, ucrit3 + real :: fmode, expdis, fdis + real :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real :: v_wdi, v_wdpc + real :: ugw, vgw, ek1, ek2, rdtp, rdtp2 + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + + real :: uz, vz, shr2 , ritur, ktur + + real :: kamp, zmetk, zgrow + real :: stab, stab_dt, dtstab + integer :: nstab, ist, anstab(levs) + real :: w1, w2, w3, dtdif + + real :: dzmetm, dzmetp, dzmetf, bdif, kturp + real :: bnrh_src +!-------------------------------------------------------------------------- +! + + if (mpi_id == master .and. kdt < 2) then + print *, im, levs, dtp, kdt, ' vay-solv2-v1' + print *, minval(tm), maxval(tm), ' min-max-tm ' + print *, minval(vm), maxval(vm), ' min-max-vm ' + print *, minval(um), maxval(um), ' min-max-um ' + print *, minval(qm), maxval(qm), ' min-max-qm ' + print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' + print *, minval(prsi), maxval(prsi), ' min-max-Pint ' + print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' + print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' + print *, minval(prslk), maxval(prslk), ' min-max-Exner ' + print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' + print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! + endif + + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + +! grav2 = grav + grav +! rgrav2 = rgrav*rgrav + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp +! +! launch level control ksrc > 2 +! + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + + jl =j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + taub_src = max(tau_ngw(jl), tau_min) + aum(km2:levs) = um(jl,km2:levs) + avm(km2:levs) = vm(jl,km2:levs) + atm(km2:levs) = tm(jl,km2:levs) + aqm(km2:levs) = qm(jl,km2:levs) + aprsl(km2:levs) = prsl(jl,km2:levs) + azmet(km2:levs) = zmet(jl,km2:levs) + aprsi(km2:levs+1) = prsi(jl,km2:levs+1) + azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk) * (1. +fv*aqm(jk)) + tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0 / (tvc+tvm) +! + uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) + vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = azmeti(jk+1)-azmeti(jk) ! >0 ...... dz-meters + zdelm = 1./(azmet(jk)-azmet(jk-1)) ! 1/dz ...... 1/meters + dzdt(jk) = dtp/zdelp +! +! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + bnk(jk) = bn(jk)*v_kxw + rhobnk(jk)=rhoint(jk)/bnk(jk)*v_kxw + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src + + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min)+kvg(k), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur*0. + 2.e-5*exp( zmetk) + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + suprf(ktop) = kion(jk) + + rhoint(ktop) = aprsi(ktop)*rdi/atm(jk) + + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) + bnk(ktop) = bn(ktop)*v_kxw + + rhobnk(ktop) = rhoint(ktop)/bnk(ktop)*v_kxw + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + bnrh_src = bvi/rhoint(ksrc) +! +! define intrinsic velocity (relative to ilaunch) u(z)-u(zo), and coefficinets +! ------------------------------------------------------------------------------------------ + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + do jk=ksrc, ktop + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1, ksrc) =0. + do inc=1,nwav + zcin = zci(inc) + zcin4 = zci4(inc)/bvi4 +! + if(nslope == 0) then + zcin3 = zci3(inc)/bvi3 + flux(inc,1) = zcin/(1.+zcin3) + endif + + if(nslope == 1) flux(inc,1) = zcin/(1.+zcin4) + if(nslope == 2) flux(inc,1)= zcin/(1.+zcin4*zcin*rcms) + +! integrate (flux x dx) + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) + + do iaz=1,nazd + akzw(inc, iaz,ksrc:ktop) = bvi*rci(inc) + enddo + + enddo +! + flux_norm = taub_src / fpu(1, ksrc) +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + enddo + +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + bnrh_src=bnrh_src*flux_norm + do jk=ksrc, ktop + fden_bn(jk) = bnrh_src*rhoint(jk) / bn(jk) !*bvi/rhoint(ksrc) + enddo + +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! copy flux-1 into other azimuths +! -------------------------------- + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! constant flux below ilaunch + do jk=km1, ksrc + do inc=1, nwav + flux_z(inc,jk)=flux(inc,1) + enddo + enddo + + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + do inc=1, nwav + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + + if (v_cdp .le. ucrit_max) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max ; wave's absorption +! + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/v_zmet(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + flux_z(inc,jkp) = fluxs +! ucrit_maxdc =0. + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + v_cdp2=v_cdp*v_cdp +! +! rotational cut-off +! + cdf2 = v_cdp2 - c2f2 + + if (cdf2 > 0.0) then + kzw2 = (bn2(jkp)-wdop2)/Cdf2 + else + kzw2 = mkz2min + endif + + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds = kxw*Cdf1*rhp2/kzw3 +! + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + supRF(jk) ! supRF - diss due to FRF-FV3dycore for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + endif + + fdis = fmode*expdis +! +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! fluxs= fden_bn(jkp)*cdf2*zcinc + fluxs= fden_bn(jkp)*sqrt(cdf2) + +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! + zdep = wave_act(inc,iaz)* (fdis-fluxs) + if(zdep > 0.0 ) then +! subs on sat-limit + flux(inc,iaz) = fluxs + flux_z(inc,jkp) = fluxs + else +! assign dis-ve flux + flux(inc,iaz) = fdis + flux_z(inc,jkp) = fdis + endif + +! cgz = bnk(jk)/max(mkz2min, kzw2) + + dtau = flux_z(inc,jk)-flux_z(inc,jkp) + if (dtau .lt. 0) flux_z(inc,jkp) = flux_z(inc,jk) + +! if (dtau .ge. ucrit_maxdc) then +! flux_z(inc,jkp) = max(flux_z(inc,jk)-ucrit_maxdc, 0.) +! ze1 = zci(inc)-umfc-ucrit_maxdc +! write(6,287) dzdt(jk)/cgz, dtau/ucrit_maxdc, flux_z(inc,jkp)*1.e3, fluxs*1.e3, jk, zci(inc), ze1 +! +! endif +! 287 format(' dtau >ucrit_max', 4(2x, F12.7), I4, 2x, 2(2x,F8.3)) +! + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 + + +! + enddo ! wave-inc-loop +! +! integrate over spectral modes fpu(y, z, azimuth) wave_act(jl,inc,iaz)*flux(jl,inc,iaz)*[d("zcinc")] +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. +! new arrays + + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + + + dfdz_v(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + fpu(iaz, jkp) = fpu(iaz,jkp) + vc_zflx_mode*zcinc + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + zdelp = wrk3(jk)*abs(zci(inc)-umfc) *zcinc + vm_zflx_mode = flux_z(inc,jk) + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) +(vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 + endif + enddo !waves inc=1,nwav + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! -------------- + enddo ! end Azimuth do-loop + +! +! extra- eddy wave dissipation to limit GW-rms +! tx1 = sum(abs(dfdz_v(jk,1:nazd)))/bn2(jk) +! ze1=max(dked_min, tx1) +! ze2=min(dked_max, ze1) +! vueff(jkp) = ze2 + vueff(jkp) +! + + + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! + fpu(1:nazd,ktop) = fpu(1:nazd, levs) + dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk)+ dfdz_v(iaz,jk) + enddo + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + + endif +! + + do jk=ksrc,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +! ek1 =aum(jk)*aum(jk) +avm(jk)*avm(jk) +! ugw = aum(jk)- ze1*dtp; vgw = avm(jk)- ze2*dtp +! ek2 = ugw*ugw +vgw*vgw +! pdtdt(jl,jk) = rdtp2*max(ek1-ek2, 0.0) !=ze1*um + 0.5*ze1^2*dtp +! pdtdt(jl,jk) = max(ze1*aum(jk) + ze2*avm(jk), 0.) ! gw_eff => in "ze1 and ze2" + pdtdt(jl,jk) = max(pdtdt(jl,jk) , 0.)*gw_eff + endif + + if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt + ze1 = max(dked_min, pdtdt(jl,jk)/bn2(jk)) + dked(jl,jk) = min(dked_max, ze1) + + enddo +! +! add limiters/efficiency for "unbalanced ics" if it is needed +! + do jk=ksrc,levs + pdtdt(jl,jk) = pdtdt(jl,jk)*rcpd + enddo +! + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, 3 + do jk=ksrc,levs-1 + adif(jk) = .25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + +! dked(jl, ksrc:levs-1) = dktur(ksrc:levs-1) +! dked(jl, levs) =dked(jl, levs-1) + +! +! perform "diffusive" 3-point smoothing of "u-v-t" +! from the surface to the "top" +! + if (knob_ugwp_dokdis == 2) then + + uold(1:levs) = aum(1:levs)+pdudt(jl,1:levs)*dtp + vold(1:levs) = avm(1:levs)+pdvdt(jl,1:levs)*dtp + told(1:levs) = atm(1:levs)+pdtdt(jl,1:levs)*dtp + + do jk=1,levs + zmetk= azmet(jk)*rhp + ktur = kvg(k) + 2.e-5*exp( zmetk) + dktur(jk) = dked(jl,jk) + ktur + enddo + + dzmetm= azmet(ksrc)- azmet(ksrc-1) + + do jk=2,levs-1 + dzmetf = (azmeti(jk+1)- azmeti(jk))*rhomid(jk) + ktur = .5*(dktur(jk-1)+dktur(jk)) *rhoint(jk)/dzmetf + kturp = .5*(dktur(jk+1)+dktur(jk))*rhoint(jk+1)/dzmetf + + dzmetp = azmet(jk+1)-azmet(jk) + Adif(jk) = ktur/dzmetm + Cdif(jk) = kturp/dzmetp + bdif = adif(jk)+cdif(jk) + if (rdtp < bdif ) then + Anstab(jk) = nint( bdif/rdtp + 1) + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + if (nstab .ge. 2) print *, 'nstab ', nstab + dtdif = dtp/real(nstab) + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = nstab*rdtp-Adif(k)-Cdif(k) + unew(k) = uold(k)*Bdif+ uold(k-1)*Adif(k) + uold(k)*Cdif(k) + vnew(k) = vold(k)*Bdif+ vold(k-1)*Adif(k) + vold(k)*Cdif(k) + tnew(k) = told(k)*Bdif+ told(k-1)*Adif(k) + told(k)*Cdif(k) + enddo + uold = unew*dtdif + vold = vnew*dtdif + told = tnew*dtdif + enddo +! +! create "smoothed" tendencies by molecular + GW-eddy diffusion +! + do k=ksrc,levs-1 + pdtdt(jl,jk)= rdtp*(told(k) - tm(jl,k)) + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 +! +! add eddy viscosity heating +! pdtdt(jl,jk) = pdtdt(jl,jk) - max(ze1*aum(jk) + ze2*avm(jk), 0.) *rcpd +! + enddo + + + ENDIF ! dissipative IF-loop for "abrupt" tendencies + + enddo ! J-loop +! + + + RETURN + +! +! Print/Debugging ----------------------------------------------------------------------- +! + 239 continue + if (kdt ==1 .and. mpi_id == master) then +! + print *, 'ugwp-vay: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwp-vay: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwp-vay: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwp-vay: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif + + + + return + end subroutine cires_ugwp_solv2_v1 + + +end module cires_ugwp_solv2_v1_mod diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 new file mode 100644 index 000000000..058003b3b --- /dev/null +++ b/physics/cires_ugwp_triggers_v1.F90 @@ -0,0 +1,576 @@ +module cires_ugwp_triggers_v1 + + +contains + + + subroutine ugwp_triggers + implicit none + write(6,*) ' physics-based triggers for UGWP ' + end subroutine ugwp_triggers +! + SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + use ugwp_common , only : deg_to_rad + + implicit none + integer :: nx, ny + real :: lon(nx), lat(ny) + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + real :: earth_r, ra1, ra2, dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + integer :: j +! +! specify common constants and +! geometric factors to compute deriv-es etc ... +! coriolis coslat tan etc... +! + earth_r = 6370.e3 + ra1 = 1.0 / earth_r + ra2 = ra1*ra1 +! + rlat = lat*deg_to_rad + rlon = lon*deg_to_rad + tanlat = atan(rlat) + cosv = cos(rlat) + dy = rlat(2)-rlat(1) + dx = rlon(2)-rlon(1) +! + do j=1, ny-1 + rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) + enddo +! + do j=2, ny-1 + brcos(j) = 1.0 / cos(rlat(j))*ra1 + enddo + + brcos(1) = brcos(2) + brcos(ny) = brcos(ny-1) + brcos2 = brcos*brcos +! + dlam1 = brcos / (dx+dx) + dlam2 = brcos2 / (dx*dx) + + dlat = ra1 / (dy+dy) + + divJp = dlat*cosv + divJM = dlat*cosv +! + do j=2, ny-1 + divJp(j) = dlat*cosv(j+1)/cosv(j) + divJM(j) = dlat*cosv(j-1)/cosv(j) + enddo + divJp(1) = divjp(2) !*divjp(1)/divjp(2) + divJp(ny) = divjp(1) + divJM(1) = divjM(2) !*divjM(1)/divjM(2) + divJM(ny) = divjM(1) +! + return + end SUBROUTINE subs_diag_geo +! + subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! compute for each Vert-column: grad(V) +! periodic in X and central diff ... +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Vx(nx, ny), Vy(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) + + end subroutine get_xy_pt + + subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) +! +! compute for each Vert-column: grad(V) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Divjp(ny), Divjm(ny) + real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) +!~~~~~~~~~~~~~~~~~~~~ +! 1/cos*d(vcos)/dy +!~~~~~~~~~~~~~~~~~~~~ + do j=2, ny-1 + Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) + enddo + Vyd(:, 1) = Vyd(:,2) + Vyd(:,ny) = Vyd(:,ny-1) + + end subroutine get_xyd_wind + + subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_fgf +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + + enddo + end subroutine trig3d_fjets + + subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_okw +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2, d1 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 + W2 = (Vx - Uyd)*(Vx - Uyd) + D1 = Ux + Vyd + trig3d_okw(:,:,k) = W1 -W2 +! trig3d_okw(:, :, k) =S2 -W2 +! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean +! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk + enddo + end subroutine trig3d_okubo +! + subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_conv + + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + integer :: k + end subroutine trig3d_dconv + + subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & + U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & + trig3d_okw, trig3d_fgf, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! +! reversed ??? Hyai, Hybi , pmid +! + real, dimension(nz+2) :: Hyai, Hybi + real, dimension(nz+1) :: Hyam, Hybm +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS, HS + real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + real :: dzkm, zkm + integer :: k +!================================================================================== +! fgf and OW-triggers +! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! +! +!=================================================================================== + + call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) + call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) +!===================================================================================================== +! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d +! +! Bulk momentum flux=/ 0 and levels for launches +! +!===================================================================================================== + 111 format(i6, 4(3x, F8.3), ' trigger-grid ') + + do k=1, nz-1 + zkm = -7.*alog(pmid(k)*1.e-3) + dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) + write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' + enddo + + end subroutine cires_3d_triggers +!================================================================================== +! tot-flux launch 0 or 1 # of Launches +! specify time-dep bulk sources: taub, klev, if_src, nf_src +! +!================================================================================== + subroutine get_spectra_tau_convgw & + (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) +! +! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function +! + integer :: nw, im, levs + integer,dimension(im,3) :: icld + real, dimension(im, levs) :: dcheat, scheat + real, dimension(im) :: precip, xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real, parameter :: precip_max = 100. ! mm/day + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + + integer :: i, k, klow, ktop, kmid + real :: dtot, dmax, daver +! + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + do i=1, im + klow = icld(i,1) + ktop = icld(i,2) + kmid= icld(i,3) + if (klow == -99 .and. ktop == -99) then + cycle + else + klev(i) = ktop + k = klow + klev(i) = k + dmax = abs(dcheat(i,k) + scheat(i,k)) + do k=klow+1, ktop + dtot =abs(dcheat(i,k) + scheat(i,k)) + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! +! klev as max( dcheat(i,k) + scheat) +! vertical width of conv-heating +! +! counts/triiger=1 & taub(i) +! + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_amp* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! 100 mb launch and MERRA-2 slat-forcing +! + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo + +! with info on precip/clouds/dc_heat create Bulk +! taub(im), klev(im) +! +! print *, ' get_spectra_tau_convgw ' + end subroutine get_spectra_tau_convgw +! + subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_fgf +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1.0 / float(kwidth) + tau_min = tau_amp*fnorm + do i=1, im +! +! only trop-c fjets so find max(trig_fgf) => klev +! use abs-values to scale tau_amp +! + + k = klow + klev(i) = k + dmax = abs(trig_fgf(i,k)) + kex = 0 + if (dmax >= tlim_fgf) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_fgf(i,k)) + if (dtot >= tlim_fgf) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo + + if (dmax .ge. tlim_fgf) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! print *, ' get_spectra_tau_nstgw ' + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo +! + end subroutine get_spectra_tau_nstgw +! + subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_okw +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1./float(kwidth) + tau_min = tau_amp*fnorm + print *, ' get_spectra_tau_okwgw ' + do i=1, im + k = klow + klev(i) = k + dmax = abs(trig_okw(i,k)) + kex = 0 + if (dmax >= tlim_okw) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_okw(i,k)) + if (dtot >= tlim_fgf ) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! + if (dmax >= tlim_okw) then + nf_src = nf_src + 1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo + print *, ' get_spectra_tau_okwgw ' + end subroutine get_spectra_tau_okw +! +! +! +!>\ingroup cires_ugwp_run +!> @{ +!! +!! + subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: tau_amp, xlatdeg(im), tau_gw(im) + real :: latdeg, flat_gw, tem + integer :: i + +! +! if-lat +! + do i=1, im + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = 0.10 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_tamp_v1 + + subroutine slat_geos5(im, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: xlatdeg(im) + real :: tau_gw(im) + real :: latdeg + real, parameter :: tau_amp = 100.e-3 + real :: trop_gw, flat_gw + integer :: i +! +! if-lat +! + trop_gw = 0.75 + do i=1, im + latdeg = xlatdeg(i) + if (-15.3 < latdeg .and. latdeg < 15.3) then + flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) + if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw + else if (latdeg > -31. .and. latdeg <= -15.3) then + flat_gw = 0.10 + else if (latdeg < 31. .and. latdeg >= 15.3) then + flat_gw = 0.10 + else if (latdeg > -60. .and. latdeg <= -31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg < 60. .and. latdeg >= 31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg <= -60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + else if (latdeg >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + end if + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5 + subroutine init_nazdir(naz, xaz, yaz) + use ugwp_common , only : pi2 + implicit none + integer :: naz + real, dimension(naz) :: xaz, yaz + integer :: idir + real :: phic, drad + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir + + +end module cires_ugwp_triggers_v1 + diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 index 0d3cce194..8b3550500 100644 --- a/physics/cires_vert_orodis.F90 +++ b/physics/cires_vert_orodis.F90 @@ -1,3 +1,9 @@ +module cires_vert_orodis + + +contains + + ! subroutine ugwp_drag_mtb ! subroutine ugwp_taub_oro ! subroutine ugwp_oro_lsatdis @@ -1016,3 +1022,5 @@ subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & enddo ! end subroutine ugwp_tofd1d + +end module cires_vert_orodis diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 55ef9c268..76c2a85aa 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -186,13 +186,6 @@ end subroutine drag_suite_init !! !> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm !> @{ -! subroutine drag_suite_run( & -! & IM,IX,KM,A,B,C,U1,V1,T1,Q1,KPBL, & -! & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & -! & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & -! & DUSFC,DVSFC,G, CP, RD, RV, IMX, & -! & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, errmsg, errflg) -! subroutine drag_suite_run( & & IM,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & @@ -206,6 +199,7 @@ subroutine drag_suite_run( & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & + & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) ! ******************************************************************** @@ -243,6 +237,15 @@ subroutine drag_suite_run( & ! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating ! gsd_diss_ht_opt = 0: dissipation heating off ! gsd_diss_ht_opt = 1: dissipation heating on +! 2020-08-25 Michael Toy changed logic control for drag component selection +! for CCPP. +! Namelist options: +! do_gsl_drag_ls_bl - logical flag for large-scale GWD + blocking +! do_gsl_drag_ss - logical flag for small-scale GWD +! do_gsl_drag_tofd - logical flag for turbulent form drag +! Compile-time options (same as before): +! gwd_opt_ls = 0 or 1: large-scale GWD +! gwd_opt_bl = 0 or 1: blocking drag ! ! References: ! Hong et al. (2008), wea. and forecasting @@ -363,12 +366,16 @@ subroutine drag_suite_run( & !------------------------------------------------------------------------- ! Flags to regulate the activation of specific components of drag suite: ! Each component is tapered off automatically as a function of dx, so best to -! keep them activated (=1). - integer, parameter :: & - gwd_opt_ls = 1, & ! large-scale gravity wave drag - gwd_opt_bl = 1, & ! blocking drag - gwd_opt_ss = 1, & ! small-scale gravity wave drag (Steeneveld et al. 2008) - gwd_opt_fd = 1, & ! form drag (Beljaars et al. 2004, QJRMS) +! keep them activated (.true.). + logical, intent(in) :: & + do_gsl_drag_ls_bl, & ! large-scale gravity wave drag and blocking + do_gsl_drag_ss, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + do_gsl_drag_tofd ! form drag (Beljaars et al. 2004, QJRMS) + +! Additional flags + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag gsd_diss_ht_opt = 0 ! Parameters for bounding the scale-adaptive variability: @@ -616,7 +623,7 @@ subroutine drag_suite_run( & enddo enddo ! - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do i = its,im dusfc_ls(i) = 0.0 dvsfc_ls(i) = 0.0 @@ -759,7 +766,8 @@ subroutine drag_suite_run( & ! ! END INITIALIZATION; BEGIN GWD CALCULATIONS: ! -IF ( ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & +IF ( (do_gsl_drag_ls_bl).and. & + ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & (ls_taper .GT. 1.E-02) ) THEN !==== ! !--- saving richardson number in usqj for migwdi @@ -895,7 +903,7 @@ subroutine drag_suite_run( & endif enddo -ENDIF ! (gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1) +ENDIF ! (do_gsl_drag_ls_bl).and.((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) !========================================================= ! add small-scale wavedrag for stable boundary layer @@ -907,7 +915,7 @@ subroutine drag_suite_run( & utendwave=0. vtendwave=0. ! - IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + IF ( (do_gsl_drag_ss).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running small-scale gravity wave drag" ! ! declaring potential temperature @@ -1008,7 +1016,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) @@ -1019,12 +1027,12 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_ss == 1 +ENDIF ! if (do_gsl_drag_ss) !================================================================ ! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): !================================================================ -IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_tofd).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running form drag" utendform=0. @@ -1066,7 +1074,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_fd(i,k) = utendform(i,k) @@ -1077,10 +1085,11 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_fd == 1 +ENDIF ! if (do_gsl_drag_tofd) !======================================================= ! More for the large-scale gwd component -IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl).and. & + (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running large-scale gravity wave drag" ! ! now compute vertical structure of the stress. @@ -1148,7 +1157,8 @@ subroutine drag_suite_run( & !=============================================================== !COMPUTE BLOCKING COMPONENT !=============================================================== -IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running blocking drag" do i = its,im @@ -1194,7 +1204,8 @@ subroutine drag_suite_run( & ENDIF ! end blocking drag !=========================================================== -IF ( (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy ! @@ -1264,7 +1275,7 @@ subroutine drag_suite_run( & dvsfc(i) = (-1./g*rcs) * dvsfc(i) enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) @@ -1279,9 +1290,9 @@ subroutine drag_suite_run( & enddo endif -ENDIF +ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls.EQ.1 .OR. gwd_opt_bl.EQ.1) -if (gwd_opt == 33) then +if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then ! Finalize dusfc and dvsfc diagnostics do i = its,im dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index dfcac8582..73a397938 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -590,6 +590,30 @@ type = integer intent = in optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 new file mode 100644 index 000000000..58872057e --- /dev/null +++ b/physics/unified_ugwp.F90 @@ -0,0 +1,686 @@ +!> \file unified_ugwp.F90 +!! This file contains the Unified Gravity Wave Physics (UGWP) scheme by Valery Yudin (University of Colorado, CIRES) +!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. +!! Unified Formalism: +!! 1. GW Sources: Stochastic and physics based mechanisms for GW-excitations in the lower atmosphere, calibrated by the high-res analyses/forecasts, and observations (3 types of GW sources: orography, convection, fronts/jets). +!! 2. GW Propagation: Unified solver for "propagation, dissipation and breaking" excited from all type of GW sources. +!! 3. GW Effects: Unified representation of GW impacts on the "resolved" flow for all sources (energy-balanced schemes for momentum, heat and mixing). +!! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf + +module unified_ugwp + + use machine, only: kind_phys + + use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + + use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp + + use gwdps, only: gwdps_run + + use drag_suite, only: drag_suite_run + + use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 + + use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 + + ! use cires_ugwp_ngw_utils, only: tau_limb_advance + + use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 + + implicit none + + private + + public unified_ugwp_init, unified_ugwp_run, unified_ugwp_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the CIRES UGWP +!> \section arg_table_unified_ugwp_init Argument Table +!! \htmlinclude unified_ugwp_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & + pa_rf_in, tau_rf_in, con_p0, do_ugwp, do_ugwp_v0, & + do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, & + errmsg, errflg) + +!---- initialization of unified_ugwp + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + character(len=*), intent (in) :: input_nml_file(:) + integer, intent (in) :: logunit + integer, intent(in) :: jdat(8) + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + real(kind=kind_phys), intent (in) :: ak(:), bk(:) + real(kind=kind_phys), intent (in) :: dtp + real(kind=kind_phys), intent (in) :: cdmbgwd(4), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes + real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in + real(kind=kind_phys), intent (in) :: con_p0 + logical, intent (in) :: do_ugwp + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only + + character(len=*), intent (in) :: fn_nml2 + !character(len=*), parameter :: fn_nml='input.nml' + + integer :: ios + logical :: exists + real :: dxsg + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + ! Test to make sure that at most only one large-scale/blocking + ! orographic drag scheme is chosen + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & + do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & + do_ugwp_v1_orog_only)) .or. & + (do_gsl_drag_ls_bl.and.(do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v1.and.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: Only one large-scale& + &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& + do_gsl_drag_ls_bl,do_ugwp_v1 or& + &do_ugwp_v1_orog_only) can be chosen" + errflg = 1 + return + + end if + + + if (is_initialized) return + + + if ( do_ugwp_v0 .and. (do_ugwp .or. cdmbgwd(3) > 0.0) ) then + if (do_ugwp .or. cdmbgwd(3) > 0.0) then + call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + else + write(errmsg,'(*(a))') "Logic error: cires_ugwp_init called but do_ugwp is false and cdmbgwd(3) <= 0" + errflg = 1 + return + end if + + + if ( do_ugwp_v1 ) then + call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, & + fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + end if + + is_initialized = .true. + + end subroutine unified_ugwp_init + + +! ----------------------------------------------------------------------- +! finalize of unified_ugwp (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP +#if 0 +!> \section arg_table_unified_ugwp_finalize Argument Table +!! \htmlinclude unified_ugwp_finalize.html +!! +#endif + subroutine unified_ugwp_finalize(errmsg, errflg) + + implicit none +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call cires_ugwp_finalize() + + is_initialized = .false. + + end subroutine unified_ugwp_finalize + + +! ----------------------------------------------------------------------- +! originally from ugwp_driver_v0.f +! driver of cires_ugwp (_driver) +! ----------------------------------------------------------------------- +! driver is called after pbl & before chem-parameterizations +! ----------------------------------------------------------------------- +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +! ----------------------------------------------------------------------- +!>@brief These subroutines and modules execute the CIRES UGWP Version 0 +!>\defgroup unified_ugwp_run Unified Gravity Wave Physics General Algorithm +!> @{ +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! +!! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. +!! +!> \section arg_table_unified_ugwp_run Argument Table +!! \htmlinclude unified_ugwp_run.html +!! +!> \section gen_unified_ugwp CIRES UGWP Scheme General Algorithm +!! @{ + subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & + lonr, oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & + do_tofd, ldiag_ugwp, cdmbgwd, jdat, xlat, xlat_d, sinlat, coslat, area, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & + del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & + dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & + rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr + integer, intent(in) :: gwd_opt + integer, intent(in), dimension(im) :: kpbl + real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,oa4ss,ol4ss,dx + logical, intent(in) :: flag_for_gwd_generic_tend + ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii + real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 + real(kind=kind_phys), intent(in) :: dtp, fhzero, cdmbgwd(4) + integer, intent(in) :: jdat(8) + logical, intent(in) :: do_tofd, ldiag_ugwp + +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + + real(kind=kind_phys), intent(in) :: br1(im), & + & hpbl(im), & + & slmsk(im) + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + + ! These arrays are only allocated if ldiag=.true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw + logical, intent(in) :: ldiag3d, lssav + + ! These arrays only allocated if ldiag_ugwp = .true. + real(kind=kind_phys), intent(out), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms + + real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt + + real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + + real(kind=kind_phys), intent(in), dimension(im) :: rain + + integer, intent(in) :: ntke + real(kind=kind_phys), intent(in), dimension(:,:) :: q_tke, dqdt_tke + + logical, intent(in) :: lprnt + integer, intent(in) :: ipr + + ! flags for choosing combination of GW drag schemes to run + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i, k + real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis + real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt + ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init + real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 + ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) + real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. + real(kind=kind_phys), parameter :: fw1_tau=1.0 + + real(kind=kind_phys), dimension(:,:), allocatable :: tke + real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1 + + real(kind=kind_phys) :: inv_g + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers + real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces + + + ! ugwp_v1 local variables + integer :: y4, month, day, ddd_ugwp, curdate, curday + integer :: hour + real(kind=kind_phys) :: hcurdate, hcurday, fhour, fhrday + integer :: kdtrest + integer :: curday_ugwp + integer :: curday_save=20150101 + logical :: first_qbo=.true. + real :: hcurday_save =20150101.00 + save first_qbo, curday_save, hcurday_save + + + ! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 + real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! 1) ORO stationary GWs + ! ------------------ + + zlwb(:) = 0. + + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme + ! Note: In case of GSL drag_suite, this includes ss and tofd + + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd ) then + + call drag_suite_run(im,levs,dvdt,dudt,dtdt,ugrs,vgrs,tgrs,q1, & + kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & + kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & + ol4ss,theta,sigma,gamma,elvmax,dtaux2d_ls, & + dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss, & + dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,dusfc, & + dvsfc,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & + con_fvirt,con_pi,lonr, & + cdmbgwd(1:2),me,master,do_gsl_drag_ls_bl, & + do_gsl_drag_ss,do_gsl_drag_tofd,lprnt,ipr,rdxzb,dx, & + gwd_opt,errmsg,errflg) + + else if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then + + ! Valery's TOFD + ! topo paras + ! w/ orographic effects + if(nmtvr == 14)then + ! calculate sgh30 for TOFD + sgh30 = abs(oro - oro_uf) + ! w/o orographic effects + else + sgh30 = 0. + endif + + inv_g = 1./con_g + zmeti = phii*inv_g + zmet = phil*inv_g + + call gwdps_oro_v1 (im, levs, lonr, do_tofd, & + Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & + prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & + clx, theta, sigma, gamma, elvmax, & + sgh30, DUSFCg, DVSFCg, xlat_d, sinlat, coslat, & + spgrid,cdmbgwd(1:2), me, master, rdxzb, & + zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & + du3dt_mtb, du3dt_ogw, du3dt_tms) + + else if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo + + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & + ugrs, vgrs, tgrs, q1, & + kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & + hprime, oc, oa4, clx, theta, sigma, gamma, & + elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, lonr, & + nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & + errmsg, errflg) + if (errflg/=0) return + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + if (ldiag_ugwp) then + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + end if + + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + Pdudt(i,k)*dtp + ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + Pdvdt(i,k)*dtp + ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + Pdtdt(i,k)*dtp + enddo + enddo + endif + + end if + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Begin non-stationary GW schemes + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! + ! ugwp_v0 non-stationary GW drag + ! + if (do_ugwp_v0) then + + if (cdmbgwd(3) > 0.0) then + + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing + call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + + if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then + if (cdmbgwd(4) > 0.0) then + allocate(turb_fac(im)) + do i=1,im + turb_fac(i) = 0.0 + enddo + if (ntke > 0) then + allocate(tke(im,levs)) + allocate(tem(im)) + tke(:,:) = q_tke(:,:) + dqdt_tke(:,:) * dtp + tem(:) = 0.0 + do k=1,(levs+levs)/3 + do i=1,im + turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) + tem(i) = tem(i) + del(i,k) + enddo + enddo + do i=1,im + turb_fac(i) = turb_fac(i) / tem(i) + enddo + deallocate(tke) + deallocate(tem) + endif + rfac = 86400000 / dtp + do i=1,im + tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + enddo + deallocate(turb_fac) + endif + do i=1,im + tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) + enddo + endif + + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_ngw, me, master, kdt) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) + !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) + !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) + !dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + enddo + enddo + + else ! .not.(cdmbgwd(3) > 0.0) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = Pdtdt(i,k) + gw_dudt(i,k) = Pdudt(i,k) + gw_dvdt(i,k) = Pdvdt(i,k) + gw_kdis(i,k) = Pkdis(i,k) + enddo + enddo + + endif ! cdmbgwd(3) > 0.0 + + if (pogw == 0.0) then + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + endif + +#if 0 + !============================================================================= + ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving + ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" + !============================================================================= + ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies + !------------------------------------------------------------------------------ + do k=1,levs + do i=1,im + ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + enddo + enddo + + call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) + gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked + gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked + gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked +#endif + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_cgw(i,k) = ldu3dt_cgw(i,k) + (gw_dudt(i,k) - Pdudt(i,k))*dtp + ldv3dt_cgw(i,k) = ldv3dt_cgw(i,k) + (gw_dvdt(i,k) - Pdvdt(i,k))*dtp + ldt3dt_cgw(i,k) = ldt3dt_cgw(i,k) + (gw_dtdt(i,k) - Pdtdt(i,k))*dtp + enddo + enddo + endif + + end if ! do_ugwp_v0 + + + ! + ! ugwp_v1 non-stationary GW drag + ! + if (do_ugwp_v1) then + +! -------- +! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing +! ---------------------------------------------- +!-------- +! GMAO GEOS-5/MERRA GW-forcing lat-dep +!-------- + call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) + + y4 = jdat(1); month = jdat(2); day = jdat(3) ; hour = jdat(5) + + ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. + fhour = (kdt-1)*dtp/3600. + fhrday = fhour/24. - nint(fhour/24.) + fhour = fhrday*24. + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp + curday = y4*10000 + month*100 + day + hcurdate = float(curdate) + fhrday + hcurday = float(curday) + fhrday +! + if (mod(fhour,fhzero) == 0 .or. first_qbo) then + + ! call tau_limb_advance(me, master, im, levs, ddd_ugwp, curdate, & + ! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + if (first_qbo) kdtrest = kdt + first_qbo = .false. + curday_save = curday + hcurday_save= hcurday + endif + + ! tau_ngw = fw1_tau*tau_ngw + tau_sat*(1.-fw1_tau) + +! goto 111 +! if (mod(fhour,fhzero) == 0 .or. first_qbo) then + +! call tau_qbo_advance(me, master, im, levs, ddd_ugwp, curdate, & +! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, j1_qbo, j2_qbo, & +! ddy_j1qbo, ddy_j2qbo, tau_sat, tau_qbo, uqbo, ax_qbo, kdt ) + + +! if (me == master) then +! print *, ' curday_save first_qbo ', curday, curday_save, kdt +! print *, ' hcurdays ', hcurdate, float(hour)/24. +! print *, jdat(5), jdat(6), jdat(7), (kdt-1)*dtp/3600., ' calendar ' +!! print *, ' curday curday_ugwp first_qbo ', hcurday, first_qbo +!! print *, ' vay_tau-limb U' , maxval(uqbo), minval(uqbo) +!! print *, ' vay_tau-limb TS' , maxval(tau_sat), minval(tau_sat) +!! print *, ' vay_tau-limb TQ' , maxval(tau_qbo), minval(tau_qbo) +! endif + + +! if (first_qbo) kdtrest = kdt +! first_qbo = .false. +! curday_save = curday +! hcurday_save= hcurday +! endif + + + + +! if (mod(kdt, 720) == 0 .and. me == master ) then +! print *, ' vay_qbo_U' , maxval(uqbo), minval(uqbo) , kdt +! endif + +! wqbo = dtp/taurel +! do k =1, levs +!! sdexpz = wqbo*vert_qbo(k) +! sdexpz = 0.25*vert_qbo(k) +! do i=1, im +!! if (dexpy(i) > 0.0) then +! dforc = 0.25 +!! ugrs(i,k) = ugrs(i,k)*(1.-dforc) + dforc*uqbo(i,levs+1-k) +!! tgrs(i,k) = tgrs(i,k)*(1.-dforc) + dforc*tqbo(i,levs+1-k) +!! endif +! enddo +! enddo + +! 111 continue + + + call cires_ugwp_solv2_v1(im, levs, dtp, & + tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & + tauabs, wrms, trms, tau_ngw, me, master, kdt) + + if (me == master .and. kdt < 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 in ugwp_driver_v0 ' + write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + endif + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) + !+(uqbo(i,levs+1-k)-ugrs(i,k))/21600. + gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k) ! + pogw*Pkdis(i,k) + enddo + enddo + + + + + if (pogw == 0.0) then +! zmtb = 0.; zogw =0. + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + endif + +! return + +!============================================================================= +! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving +! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" +!============================================================================= +! +! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies +!------------------------------------------------------------------------------ + +! ed_dudt(:,:) = 0.0 ; ed_dvdt(:,:) = 0.0 ; ed_dtdt(:,:) = 0.0 + + + +! call edmix_ugwp_v1(im, levs, dtp, & +! tgrs, ugrs, vgrs, q1, del, & +! prsl, prsi, phil, prslk, & +! gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & +! ed_dudt, ed_dvdt, ed_dTdt, +! me, master, kdt ) + +! do k=1,levs +! do i=1,im +! gw_dtdt(i,k) = gw_dtdt(i,k) + ed_dtdt(i,k)*pked +! gw_dvdt(i,k) = gw_dvdt(i,k) + ed_dvdt(i,k)*pked +! gw_dudt(i,k) = gw_dudt(i,k) + ed_dudt(i,k)*pked +! enddo +! enddo + + + end if ! do_ugwp_v1 + + + end subroutine unified_ugwp_run +!! @} +!>@} +end module unified_ugwp diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta new file mode 100644 index 000000000..5c0eb458b --- /dev/null +++ b/physics/unified_ugwp.meta @@ -0,0 +1,1296 @@ +[ccpp-arg-table] + name = unified_ugwp_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for opening namelist file + units = none + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=* + intent = in + optional = F +[logunit] + standard_name = iounit_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in + optional = F +[fn_nml2] + standard_name = namelist_filename + long_name = namelist filename for ugwp + units = none + dimensions = () + type = character + kind = len=* + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[latr] + standard_name = number_of_latitude_points + long_name = number of global points in y-dir (j) along the meridian + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ak] + standard_name = a_parameter_of_the_hybrid_coordinate + long_name = a parameter for sigma pressure level calculations + units = Pa + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[bk] + standard_name = b_parameter_of_the_hybrid_coordinate + long_name = b parameter for sigma pressure level calculations + units = none + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer +[cgwf] + standard_name = multiplication_factors_for_convective_gravity_wave_drag + long_name = multiplication factor for convective GWD + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[pa_rf_in] + standard_name = pressure_cutoff_for_rayleigh_damping + long_name = pressure level from which Rayleigh Damping is applied + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tau_rf_in] + standard_name = time_scale_for_rayleigh_damping + long_name = time scale for Rayleigh damping in days + units = d + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_p0] + standard_name = standard_atmospheric_pressure + long_name = standard atmospheric pressure + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_run + type = scheme +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fhzero] + standard_name = hours_between_clearing_of_diagnostic_buckets + long_name = hours between clearing of diagnostic buckets + units = h + dimensions = () + type = real + kind = kind_phys +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[oro] + standard_name = orography + long_name = orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oro_uf] + standard_name = orography_unfiltered + long_name = unfiltered orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of topographic variables in GWD + units = count + dimensions = () + type = integer + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degree + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtaux2d_ls] + standard_name = x_momentum_tendency_from_large_scale_gwd + long_name = x momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ls] + standard_name = y_momentum_tendency_from_large_scale_gwd + long_name = y momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_bl] + standard_name = x_momentum_tendency_from_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_bl] + standard_name = y_momentum_tendency_from_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ss] + standard_name = x_momentum_tendency_from_small_scale_gwd + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ss] + standard_name = y_momentum_tendency_from_small_scale_gwd + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_fd] + standard_name = x_momentum_tendency_from_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_fd] + standard_name = y_momentum_tendency_from_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[varss] + standard_name = standard_deviation_of_subgrid_orography_small_scale + long_name = standard deviation of subgrid orography small scale + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oc1ss] + standard_name = convexity_of_subgrid_orography_small_scale + long_name = convexity of subgrid orography small scale + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oa4ss] + standard_name = asymmetry_of_subgrid_orography_small_scale + long_name = asymmetry of subgrid orography small scale + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4ss] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height small scale + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[do_tofd] + standard_name = turb_oro_form_drag_flag + long_name = flag for turbulent orographic form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sinlat] + standard_name = sine_of_latitude + long_name = sine of the grid latitude + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[coslat] + standard_name = cosine_of_latitude + long_name = cosine of the grid latitude + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between midlayers + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_kdis] + standard_name = eddy_mixing_due_to_ugwp + long_name = eddy mixing due to UGWP + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_tms] + standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[q_tke] + standard_name = turbulent_kinetic_energy + long_name = turbulent kinetic energy + units = J + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqdt_tke] + standard_name = tendency_of_turbulent_kinetic_energy_due_to_model_physics + long_name = turbulent kinetic energy tendency due to model physics + units = J s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[ldu3dt_ogw] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in x wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ogw] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in y wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ogw] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldu3dt_cgw] + standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in x wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_cgw] + standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in y wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_cgw] + standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag + long_name = cumulative change in temperature due to convective gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_gravity_wave_drag_tendency + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 new file mode 100644 index 000000000..ac11b4eb1 --- /dev/null +++ b/physics/unified_ugwp_post.F90 @@ -0,0 +1,83 @@ +!> \file unified_ugwp_post.F90 +!! This file contains +module unified_ugwp_post + +contains + +!>\defgroup unified_ugwp_post CIRES UGWP Scheme Post +!! @{ +!> \section arg_table_unified_ugwp_post_init Argument Table +!! + subroutine unified_ugwp_post_init () + end subroutine unified_ugwp_post_init + +!>@brief The subroutine initializes the CIRES UGWP +#if 0 +!> \section arg_table_unified_ugwp_post_run Argument Table +!! \htmlinclude unified_ugwp_post_run.html +!! +#endif + + + subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & + gw_dtdt, gw_dudt, gw_dvdt, tau_tofd, tau_mtb, tau_ogw, & + tau_ngw, zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & + tot_zmtb, tot_zlwb, tot_zogw, & + tot_tofd, tot_mtb, tot_ogw, tot_ngw, & + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtf + logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics + + real(kind=kind_phys), intent(in), dimension(:) :: zmtb, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(:) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_zmtb, tot_zlwb, tot_zogw + real(kind=kind_phys), intent(in), dimension(:,:) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zmtb + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *tau_tofd + tot_mtb = tot_mtb + dtf *tau_mtb + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_mtb + du3dt_tms = du3dt_tms + dtf *dudt_tms + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *gw_dudt + dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt + endif + + dtdt = dtdt + gw_dtdt + dudt = dudt + gw_dudt + dvdt = dvdt + gw_dvdt + + end subroutine unified_ugwp_post_run + +!> \section arg_table_unified_ugwp_post_finalize Argument Table +!! + subroutine unified_ugwp_post_finalize () + end subroutine unified_ugwp_post_finalize + +!! @} +end module unified_ugwp_post diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta new file mode 100644 index 000000000..807584e94 --- /dev/null +++ b/physics/unified_ugwp_post.meta @@ -0,0 +1,315 @@ +[ccpp-arg-table] + name = unified_ugwp_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_run + type = scheme +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_tms] + standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tot_zmtb] + standard_name = time_integral_of_height_of_mountain_blocking + long_name = time integral of height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zlwb] + standard_name = time_integral_of_height_of_low_level_wave_breaking + long_name = time integral of height of drag due to low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zogw] + standard_name = time_integral_of_height_of_launch_level_of_orographic_gravity_wave + long_name = time integral of height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_tofd] + standard_name = time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = time integral of momentum flux due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_mtb] + standard_name = time_integral_of_momentum_flux_due_to_mountain_blocking_drag + long_name = time integral of momentum flux due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ogw] + standard_name = time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = time integral of momentum flux due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ngw] + standard_name = time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave + long_name = time integral of momentum flux due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ngw] + standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in x wind due to NGW + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt_ngw] + standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in y wind due to NGW + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_finalize + type = scheme From e19d00da14a774ad970f519a055b2a4718c442ac Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Sep 2020 17:29:34 -0600 Subject: [PATCH 14/45] Increase length of message and update declaration in qcmxmn to avoid writing out of bounds --- physics/sfcsub.F | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 30f663ec5..57aff87d4 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -43,10 +43,8 @@ function message(prefix,index) implicit none character(len=*), intent(in) :: prefix integer, intent(in) :: index - character(len=10) :: message - ! - ! probably need to implement a check that len(prefix) + '-' + length of - ! string representation of index <= len(message) + ! Safety measure: prevent writing out of bounds, use a longer string + character(len=128) :: message write(message,fmt='(a,a,i0)') trim(prefix), '-', index end function message @@ -5234,7 +5232,7 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & & ij,nprt,kmaxs,kmins,i,me,len,mode parameter(mmprt=2) ! - character*8 ttl + character(len=*) ttl logical iceflg(len) real (kind=kind_io8) fld(len),slimsk(len),sno(len), & & rla(len), rlo(len) From 317c5cd465bedbba939295d59e0503eea8d057c1 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 3 Sep 2020 15:10:19 -0600 Subject: [PATCH 15/45] physics/sfcsub.F: reduce length of message string for prettier output --- physics/sfcsub.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 57aff87d4..b0fe168bd 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -43,8 +43,8 @@ function message(prefix,index) implicit none character(len=*), intent(in) :: prefix integer, intent(in) :: index - ! Safety measure: prevent writing out of bounds, use a longer string - character(len=128) :: message + ! Safety measure: prevent writing out of bounds, use a longer string than 8 characters + character(len=16) :: message write(message,fmt='(a,a,i0)') trim(prefix), '-', index end function message From 3a727b952107b6d27d4ebf129dcd75a0b627c189 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Fri, 4 Sep 2020 03:02:17 +0000 Subject: [PATCH 16/45] 2nd try -- Sept. 3 -- two scheme test --- physics/cires_orowam2017.F90 | 28 +- physics/cires_ugwp_initialize_v1.F90 | 54 +- physics/cires_ugwp_module_v1.F90 | 22 +- physics/cires_ugwp_orolm97_v1.F90 | 21 +- physics/cires_ugwp_solv2_v1_mod.F90 | 8 +- physics/cires_ugwp_triggers_v1.F90 | 4 +- physics/cires_vert_orodis.F90 | 8 - physics/cires_vert_orodis_v1.F90 | 1026 ++++++++++++++++++++++++++ physics/unified_ugwp.F90 | 12 +- 9 files changed, 1105 insertions(+), 78 deletions(-) create mode 100644 physics/cires_vert_orodis_v1.F90 diff --git a/physics/cires_orowam2017.F90 b/physics/cires_orowam2017.F90 index 752c6f84e..d5568bb9d 100644 --- a/physics/cires_orowam2017.F90 +++ b/physics/cires_orowam2017.F90 @@ -4,13 +4,13 @@ module cires_orowam2017 contains - subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, - & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, - & del, sigma, hprime, gamma, theta, + subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & + & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & + & del, sigma, hprime, gamma, theta, & & sinlat, xlatd, taup, taud, pkdis) ! USE MACHINE , ONLY : kind_phys - use ugwp_common , only : grav, omega2 + use ugwp_common_v1 , only : grav, omega2 ! implicit none @@ -22,12 +22,12 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, real(kind=kind_phys), intent(in) :: taub(im) real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) - real(kind=kind_phys), intent(in), dimension(im) :: sigma, + real(kind=kind_phys), intent(in), dimension(im) :: sigma, & & hprime, gamma, theta real(kind=kind_phys), intent(in), dimension(im) :: xn, yn - real(kind=kind_phys), intent(in), dimension(im, levs) :: + real(kind=kind_phys), intent(in), dimension(im, levs) :: & & u1, v1, t1, bn2, rho, prsl, del real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi @@ -102,8 +102,8 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, if (kdt == 1) then 771 format( 'vay-oro19 ', 3(2x,F8.3)) - write(6,771) - & maxval(tau_kx)*maxval(taub)*1.e3, + write(6,771) & + & maxval(tau_kx)*maxval(taub)*1.e3, & & minval(tau_kx), maxval(tau_kx) endif ! @@ -127,9 +127,9 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, taub_kx(1:nw) = tau_kx(1:nw) * taub(i) wkdis(:,:) = kedmin - call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), - & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), - & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & + & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), & + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & & xn(i), yn(i)) fcor2 = (omega2*sinlat(j))*(omega2*sinlat(j))*fc_flag @@ -242,7 +242,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, wrms(iw,k) = etwk tauk = etwk*kxw/kzw tau_sp(iw,k) = tauk *rhoint - if ( tau_sp(iw,k) > tau_sp(iw,k-1)) + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) & & tau_sp(iw,k) = tau_sp(iw,k-1) ENDIF ! upward @@ -281,10 +281,10 @@ end subroutine oro_wam_2017 ! define mean flow and dissipation for OGW-kx spectrum ! !------------------------------------------------------------- - subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) - use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min + use ugwp_common_v1 , only : grav, rgrav, rdi, velmin, dw2min implicit none integer :: nz, nzi diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 index eef5cc04e..174a871d1 100644 --- a/physics/cires_ugwp_initialize_v1.F90 +++ b/physics/cires_ugwp_initialize_v1.F90 @@ -10,7 +10,7 @@ ! ! - module ugwp_common + module ugwp_common_v1 ! ! use machine, only : kind_phys ! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & @@ -46,7 +46,7 @@ module ugwp_common real, parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin real, parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax real, parameter :: cdmin = 2.e-2/mkzmax - end module ugwp_common + end module ugwp_common_v1 ! ! !=================================================== @@ -56,7 +56,7 @@ end module ugwp_common !=================================================== subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) - use ugwp_common, only : pih + use ugwp_common_v1, only : pih implicit none @@ -178,13 +178,13 @@ end subroutine rf_damp_init ! wave sources ! ======================================================================== ! -! ugwp_oro_init +! ugwp_oro_init_v1 ! !========================================================================= - module ugwp_oro_init + module ugwp_oro_init_v1 - use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi - use ugwp_common, only : mkzmin, mkz2min + use ugwp_common_v1, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common_v1, only : mkzmin, mkz2min implicit none ! ! constants and "crirtical" values to run oro-mtb_gw physics @@ -281,7 +281,7 @@ subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & real, parameter :: lonr_refmb = 4.0 * 192.0 real, parameter :: lonr_refgw = 192.0 -! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch +! copy to "ugwp_oro_init_v1" => nwaves, nazdir, nstoch nworo = nwaves nazoro = nazdir @@ -306,13 +306,13 @@ subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & end subroutine init_oro_gws ! - end module ugwp_oro_init + end module ugwp_oro_init_v1 ! ========================================================================= ! -! ugwp_conv_init +! ugwp_conv_init_v1 ! !========================================================================= - module ugwp_conv_init + module ugwp_conv_init_v1 implicit none real :: eff_con ! scale factors for conv GWs @@ -336,7 +336,7 @@ module ugwp_conv_init ! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & lonr, kxw, cgwf) - use ugwp_common, only : pi2, arad + use ugwp_common_v1, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch @@ -382,14 +382,14 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & end subroutine init_conv_gws - end module ugwp_conv_init + end module ugwp_conv_init_v1 !========================================================================= ! -! ugwp_fjet_init +! ugwp_fjet_init_v1 ! !========================================================================= - module ugwp_fjet_init + module ugwp_fjet_init_v1 implicit none real :: eff_fj ! scale factors for conv GWs integer :: nwfj ! number of waves @@ -406,7 +406,7 @@ module ugwp_fjet_init real, allocatable :: xaz_fjet(:), yaz_fjet(:) contains subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common, only : pi2, arad + use ugwp_common_v1, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch @@ -435,12 +435,12 @@ subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) end subroutine init_fjet_gws - end module ugwp_fjet_init + end module ugwp_fjet_init_v1 ! !========================================================================= ! ! - module ugwp_okw_init + module ugwp_okw_init_v1 !========================================================================= implicit none @@ -461,7 +461,7 @@ module ugwp_okw_init ! subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common, only : pi2, arad + use ugwp_common_v1, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch @@ -490,7 +490,7 @@ subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) end subroutine init_okw_gws - end module ugwp_okw_init + end module ugwp_okw_init_v1 !=============================== end of GW sources ! @@ -501,7 +501,7 @@ end module ugwp_okw_init ! Part -3 init wave solvers !=============================== - module ugwp_lsatdis_init + module ugwp_lsatdis_init_v1 implicit none integer :: nwav, nazd @@ -543,14 +543,14 @@ subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb ! end subroutine initsolv_lsatdis ! - end module ugwp_lsatdis_init + end module ugwp_lsatdis_init_v1 ! ! - module ugwp_wmsdis_init + module ugwp_wmsdis_init_v1 - use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 - use ugwp_common, only : bnv2max, bnv2min, minvel - use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin + use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 + use ugwp_common_v1, only : bnv2max, bnv2min, minvel + use ugwp_common_v1, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin implicit none real, parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 @@ -782,7 +782,7 @@ end subroutine initsolv_wmsdis ! make a list of all-initilized parameters needed for "gw_solver_wmsdis" ! - end module ugwp_wmsdis_init + end module ugwp_wmsdis_init_v1 !========================================================================= ! ! work TODO for 2-extra WAM-solvers: diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 index ecc00ecfb..dc586c6bd 100644 --- a/physics/cires_ugwp_module_v1.F90 +++ b/physics/cires_ugwp_module_v1.F90 @@ -9,7 +9,7 @@ module cires_ugwp_module_v1 !................................................................................... ! ! - use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 implicit none logical :: module_is_initialized !logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction @@ -176,18 +176,18 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & ! ! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 ! - ! use netcdf - use ugwp_oro_init, only : init_oro_gws - use ugwp_conv_init, only : init_conv_gws - use ugwp_fjet_init, only : init_fjet_gws - use ugwp_okw_init, only : init_okw_gws - use ugwp_wmsdis_init, only : initsolv_wmsdis + use netcdf + use ugwp_oro_init_v1, only : init_oro_gws + use ugwp_conv_init_v1, only : init_conv_gws + use ugwp_fjet_init_v1, only : init_fjet_gws + use ugwp_okw_init_v1, only : init_okw_gws + use ugwp_wmsdis_init_v1, only : initsolv_wmsdis - use ugwp_lsatdis_init, only : initsolv_lsatdis + use ugwp_lsatdis_init_v1, only : initsolv_lsatdis - use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar - use ugwp_wmsdis_init, only : tau_min, tamp_mpa + use ugwp_wmsdis_init_v1, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init_v1, only : tau_min, tamp_mpa implicit none integer, intent (in) :: me @@ -322,7 +322,7 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & IF (do_physb_gwsrcs) THEN - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' + if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_v1 ' if (knob_ugwp_wvspec(4) > 0) then ! okw call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 index 1a6cedcb3..e6c3a1ea0 100644 --- a/physics/cires_ugwp_orolm97_v1.F90 +++ b/physics/cires_ugwp_orolm97_v1.F90 @@ -8,7 +8,7 @@ module cires_ugwp_orolm97_v1 subroutine gwdps_oro_v1(im, km, imx, do_tofd, & pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & - oc, oa4, clx4, theta, sigma, gamma, elvmaxd, sgh30, & + oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, sgh30, & dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & cdmbgwd, me, master, rdxzb, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & @@ -23,12 +23,12 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & !---------------------------------------- use machine , only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2, & + use ugwp_common_v1, only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2, & pi, rad_to_deg, deg_to_rad, pi2, & rdi, gor, grcp, gocp, fv, gr2, & bnv2min, dw2min, velmin, arad - use ugwp_oro_init, only : rimin, ric, efmin, efmax , & + use ugwp_oro_init_v1, only : rimin, ric, efmin, efmax , & hpmax, hpmin, sigfaci => sigfac , & dpmin, minwnd, hminmt, hncrit , & rlolev, gmax, veleps, factop , & @@ -37,11 +37,11 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & cdmb, cleff, fcrit_gfs, fcrit_mtb, & n_tofd, ze_tofd, ztop_tofd - use cires_ugwp_module, only : kxw, max_kdis, max_axyz + use cires_ugwp_module_v1, only : kxw, max_kdis, max_axyz use cires_orowam2017, only : oro_wam_2017 - use cires_vert_orodis, only : ugwp_tofd1d + use cires_vert_orodis_v1, only : ugwp_tofd1d ! use sso_coorde, only : pgwd, pgwd4 @@ -67,8 +67,8 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & real(kind=kind_phys), intent(in) :: cdmbgwd(2) real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & - clx4(im,4), theta(im), sigma(im), & - gamma(im), elvmaxd(im) + clx4(im,4), theta(im), sigmad(im), & + gammad(im), elvmaxd(im) real(kind=kind_phys), intent(in) :: sgh30(im) real(kind=kind_phys), intent(in), dimension(im,km) :: & @@ -118,7 +118,8 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco !mtb - real(kind=kind_phys), dimension(im) :: oa, clx , elvmax, wk + real(kind=kind_phys), dimension(im) :: oa, clx , sigma, gamma, & + elvmax, wk real(kind=kind_phys), dimension(im) :: pe, ek, up real(kind=kind_phys), dimension(im,km) :: db, ang, uds @@ -174,6 +175,10 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & integer :: k_mtb, k_zlow, ktrial, klevm1 integer :: i, j, k ! +! initialize gamma and sigma + gamma(:) = gammad(:) + sigma(:) = sigmad(:) +! rcpdt = 1.0 / (cpd*dtp) grav2 = grav + grav ! diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 index ec2ec7bf2..c84028199 100644 --- a/physics/cires_ugwp_solv2_v1_mod.F90 +++ b/physics/cires_ugwp_solv2_v1_mod.F90 @@ -26,18 +26,18 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & use machine, only : kind_phys - use cires_ugwp_module,only : krad, kvg, kion, ktg + use cires_ugwp_module_v1,only : krad, kvg, kion, ktg - use cires_ugwp_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + use ugwp_common_v1 , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & omega2, rcpd, rcpd2, pi, pi2, fv, & rad_to_deg, deg_to_rad, & rdi, gor, grcp, gocp, & bnv2min, bnv2max, dw2min, velmin, gr2, & hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min ! - use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + use ugwp_wmsdis_init_v1, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & nslope, ilaunch, zms, & zci, zdci, zci4, zci3, zci2, & diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 index 058003b3b..44911e1d5 100644 --- a/physics/cires_ugwp_triggers_v1.F90 +++ b/physics/cires_ugwp_triggers_v1.F90 @@ -11,7 +11,7 @@ end subroutine ugwp_triggers ! SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - use ugwp_common , only : deg_to_rad + use ugwp_common_v1 , only : deg_to_rad implicit none integer :: nx, ny @@ -545,7 +545,7 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) ! end subroutine slat_geos5 subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common , only : pi2 + use ugwp_common_v1 , only : pi2 implicit none integer :: naz real, dimension(naz) :: xaz, yaz diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 index 8b3550500..0d3cce194 100644 --- a/physics/cires_vert_orodis.F90 +++ b/physics/cires_vert_orodis.F90 @@ -1,9 +1,3 @@ -module cires_vert_orodis - - -contains - - ! subroutine ugwp_drag_mtb ! subroutine ugwp_taub_oro ! subroutine ugwp_oro_lsatdis @@ -1022,5 +1016,3 @@ subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & enddo ! end subroutine ugwp_tofd1d - -end module cires_vert_orodis diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 new file mode 100644 index 000000000..c328a3fb6 --- /dev/null +++ b/physics/cires_vert_orodis_v1.F90 @@ -0,0 +1,1026 @@ +module cires_vert_orodis_v1 + + +contains + + +! subroutine ugwp_drag_mtb +! subroutine ugwp_taub_oro +! subroutine ugwp_oro_lsatdis +! + subroutine ugwp_drag_mtb( iemax, nz, & + elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & + up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) + + use ugwp_common_v1, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi + use ugwp_oro_init_v1, only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver + + implicit none +!======================== +! several versions for drmtb => high froude mountain blocking +! version 1 => vay_2018 ; +! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 +! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 +!======================== +! real, parameter :: Fcrit_mtb = 0.7 + + integer, intent(in) :: nz + integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime + real , intent(out) :: taumtb + + integer , intent(out) :: idxzb + real, dimension(nz), intent(out) :: drmtb + + real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) + real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam + real, intent(in) :: zpbl + + real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid + real, dimension(nz+1), intent(in) :: zpi, pint +! + real, dimension(nz+1) :: zpi_zero + real, dimension(nz) :: zpm_zero + real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp + + real, dimension(nz) :: bn2, uds, umf, cosang, sinang + + integer :: k, klow, ktop, kpbl + real :: uhm, vhm, bn2hm, rhohm, & + mtb_fix, umag, bnmag, frd_src, & + zblk, who_iz_normal, rlm97, & + phiang, ang, pe, ek, & + cang, sang, ss2, cs2, zlen, dbtmp, & + hamp, bgamm, cgamm + +!================================================== +! +! elvp + hprime <=>elvp + nridge*hprime, ns =2 +! ns = sigfac +! tau_parel & tau_normal along major "axes" +! +! options to block the "flow", choices for [klow, ktop] +! +! 1-directional (normal) & 2-directional "blocking" +! +!================================================== +! no - blocking: drmtb(1:nz) = 0.0 +!================= + idxzb = -1 + drmtb(1:nz) = 0.0 + taumtb = 0.0 + klow = 2 + + ktop = iemax + hamp = nridge*hprime + +! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime + + mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp + + if (mtb_fix == 0.) then + print *, cdmb, sigma, hamp + print *, ' MTB == 0' + stop + endif + + if (strver == 'vay_2018') then + + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + + do k=1, nz-1 + if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then + ktop = k+1 !......simply k+1 next interface level + exit + endif + enddo +! print *, klow, ktop, ' klow-ktop ' + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s + if (bn2hm .le. 0.0) then + print *, ' unstable MF for MTB -RETURN ' + RETURN ! unstable PBL + endif + bnmag =sqrt(bn2hm) + + frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. + +! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' +! + if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking +! +! zblk > 0 +! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk +! + zblk = hamp*(1. - Fcrit_mtb/frd_src) + idxzb =1 + do k = 2, ktop + + if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then + idxzb = k + exit + endif + enddo +! + if (idxzb == 1) RETURN ! first surface level block is not "important" + + if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 +! +! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 +! + bgamm = 1.0 - 0.18*gam -0.04*gam*gam + cgamm = 0.48*gam +0.3*gam*gam + + do k = 1, idxzb-1 + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + + umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + + phiang = atan(vp(k)/umag) +! theta -90/90 + ang = theta - phiang + cang = cos(ang) ; sang = sin(ang) + + who_iz_normal = max(cang, gam*sang ) !gfs-2018 + + cs2 = cang* cang ; ss2 = 1.-cs2 + + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it +! + if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level +! + + who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS + + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + if (dbtmp < 0) dbtmp = 0.0 +! +! several approximation can be made to implement MTB-drag +! as a "nonlinear level dependent"-drag or "constant"-drag +! uds(k) == umag = const between the 1-layer and idxzb +! + + drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u + taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! +! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used +! with Umag-projections on A & B ellipse axes +! mtb_fix =0.25*cdmb*sigma/hprime, +! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. +! +!333 format(i4, 7(2x, F10.3)) +! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 + enddo +! + endif + endif ! strver=='vay_2018' +! +! +! + if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then + + print *, ' kdn_2005 with # of hills ' +! +! compute flow-blocking stress based on WRF 'gwdo2d' +! + endif +! +! + if (strver == 'gfs_2018') then + + ktop = iemax; klow = 2 + + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + if (bn2hm <= 0.0) RETURN ! unstable PBL +!--------------------------------------------- +! +!'gfs_2018' .... does not rely on Fr_crit +! and Fr-regimes +!----gfs17 for mtn ignores "averaging of the flow" +! for MTB-part it is only works with "angles" +! no projections on [uhm, vhm] -direction +! kpbl can be used for getting high values of iemax-hill +!----------------------------------------------------------- + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + do k=1, nz-1 + if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then + kpbl = k+1 + exit + endif + enddo + + do k = iemax, 1, -1 + + uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + phiang = atan(vp(k)/uds(k)) + ang = theta - phiang + cosang(k) = cos(ang) + sinang(k) = sin(ang) + + if (idxzb == 0) then + pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) + umf(k) = uds(k) * cosang(k) ! normal to main axis + ek = 0.5 * umf(k) * umf(k) +! +! --- dividing stream lime is found when pe =>exceeds ek first from the "top" +! + if (pe >= ek) idxzb = k + exit + endif + enddo + +! idxzb = min(kpbl, idxzb) +! +! +! +! last: mtb-drag +! + if (idxzb > 1) then + zblk = zpm(idxzb) + print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) + do k = idxzb-1, 1, -1 +! + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + cs2 = cosang(k)* cosang(k) + ss2 = 1.-cs2 + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it + + who_iz_normal = max(cosang(k), gam*sinang(k)) +! +! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) +! + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + + drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u +! + taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! + enddo + endif + endif ! strver=='gfs17' +! +! + end subroutine ugwp_drag_mtb +! +! +! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] +! +! + subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & + hprime , sigma, theta, oc, oa4, clx4, gamm, & + elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & + tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) +! + use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin + use ugwp_common_v1, only : mkz2min, mkzmin + use cires_ugwp_module_v1, only : frcrit, ricrit, linsat + use ugwp_oro_init_v1, only : hpmax, cleff, frmax + use ugwp_oro_init_v1, only : nwdir, mdir, fdir + use ugwp_oro_init_v1, only : efmin, efmax , gmax, cg, ceofrc + use ugwp_oro_init_v1, only : fcrit_sm, fcrit_gfs, frmin, frmax + use ugwp_oro_init_v1, only : coro, nridge, odmin, odmax + use ugwp_oro_init_v1, only : strver +! + use ugwp_oro_init_v1, only : zbr_pi +! --- +! +! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) +! approximate for drlee-momentum tendency +! --- + implicit none +! + integer, intent(in) :: levs, izb + real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero + integer, intent(out) :: kdswj, krefj, kotr + integer :: klwb + real, intent(in) :: kxw, fcor + real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp + +! + real, intent(in) :: oa4(4), clx4(4) + + real, dimension(levs), intent(in) :: up, vp, tp, qp, dp + real, dimension(levs+1), intent(in) :: zpi, pint + real, dimension(levs ), intent(in) :: zpm, pmid +! + real,dimension(levs), intent(out) :: drlee + real,dimension(levs+1), intent(out) :: tau_src +! + real, intent(out) :: tauogw, tautot, taulee + real :: taulin, tauhcr, taumtb + real, intent(out) :: xn, yn, umag, kxridge +! +! +! locals +! four possible versions to compute "taubase as a function of Fr-number" +! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' +! + real, dimension(levs+1) :: zpi_zero + + real :: oa, clx, odir, cl4p(4), clxp + + real :: uhm, vhm, bn2hm, rhohm, bnv + + real :: elvpMTB, wdir + real :: tem, efact, coefm, kxlinv, gfobnv + + real :: fr, frlin, frlin2, frlin3, frlocal, dfr + real :: betamax, betaf, frlwb, frmtb + integer :: klow, ktop, kph + + integer :: i, j, k, nwd, ind4, idir + + real :: sg_ridge, kx2, umd2 + real :: mkz, mkz2, zbr_mkz, mkzi + + real :: hamp ! clipped hprime*elvmax/elv_clip > hprime + real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) + real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves + real :: hcrit + real :: hblk ! blocking div-stream height + + real :: coef_h2, frnorm + + + real, dimension(levs) :: bn2 + real :: rho(levs) + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + real, dimension(levs+1) :: umd, phmkz + real :: c2f2, umag2, dzwidth, udir + real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp + real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms + real, dimension(levs+1) :: dtrans, deff + real :: pdtrans + logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 + logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum + ! between ZMTB => ZHILL +!----------------------------------------------------------------------------- +! +! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) +! ZMTB < ZOGW = ns*HPRIME < ELVP +! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB +! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new +! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW +! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB +! +!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] +! can be based on numerical runs like WRF-model +! for Frc < Fr< [Frc : 2.5-3 Frc] +! see suggestions proposed in SM-2000 and Eckermann et al. (2010) +!----------------------------------------------------------------------------- + tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 + krefj = 1 ; kotr = levs+1; kdswj = 1 + xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw + + dtrans = 0. ; deff =0. + klow = 2 + elvpMTB = elvp +! +! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB +! + if (izb > 0 ) then + klow = izb + elvpMTB = max(elvp - zpi(izb), 0.0) + endif + if (elvpMTB <=0 ) print *, ' blocked flow ' + if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX + + zpi_zero(:) = zpi(:) - zpi(1) + hblk = zpi_zero(klow) + + sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) + +! +! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp +! + sg_ridge = min(sg_ridge, hpmax) + +! print *, 'sg_ridge ', sg_ridge + + do k=1, levs + if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then + ktop = k+1 + exit + endif + enddo + + krefj = ktop ! the mountain top index for sg_ridge = ns*hprime + +! if ( izb > 0 .and. krefj .le. izb) then +! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' +! endif + +! +! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L +! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution +! + call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + call get_unit_vector(uhm, vhm, xn, yn, umag) + + if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment + bnv = sqrt(bn2hm) + hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer + hogw = hamp + hdsw = hamp + + + fr = bnv * hamp /umag + fr = min(fr, frmax) + kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx + kx2 = kxridge*kxridge + umag = max( umag, velmin) + c2f2 = fcor*fcor/kx2 + umag2 = umag*umag - c2f2 + + if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx + + mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" + ! and non-stationary waves coro, fcor for small umag + ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg + IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN +! +! case then no effects of wave-orography +! + krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 + tautot = 0. + tauogw = 0. + taulee = 0. + drlee = 0. ; tau_src(1:levs+1) = 0. + return + ENDIF +!========================================================================= +! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! make sure that SM_00 and KD_05 oro-characteristics can match each other +! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime +! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] +! alph-SM00 fraction of h2d contributed to hprime [0:1] +! +! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] +! delt-SM00 dw/up asymmetry -1 < delta < 1 +! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 +!.. +!A parametrization of low-level wave breaking which includes a dependence on +!the degree of 2-dimensionality of SG; it is active over a finite range of Fr +!========================================================================= + wdir = atan2(uhm,vhm) + pi + idir = mod( int(fdir*wdir),mdir) + 1 + + nwd = nwdir(idir) + ind4 = mod(nwd-1,4) + 1 + if (ind4 < 1 ) ind4 = 1 + if (ind4 > 4 ) ind4 = 4 + + oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) + clx = clx4(ind4) + cl4p(1) = clx4(2) + cl4p(2) = clx4(1) + cl4p(3) = clx4(4) + cl4p(4) = clx4(3) + clxp = cl4p(ind4) + + odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" + + odir = min(odmax, odir) + odir = max(odmin, odir) + + + if (strver == 'smc_2000' .or. strver == 'vay_2018') then +!========================================================================= +! +! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb +! taulin/tauogw taulee taumtb +! here tau_src(levs+1): approximate wave flux from surface to LLWB +! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) +!========================================================================= +! +! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 +! wave flux ~ rho_src*kx_src/mkz_src*wind_rms +! bn2, uhm, vhm, bn2hm, rhohm +! +! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN +! +! wave regimes +! + mkz = sqrt(mkz2) + frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb + frlin = fcrit_sm + frlin2 = 1.5*fcrit_sm + frlin3 = 3.0*fcrit_sm + + hcrit = fcrit_sm*umag/bnv + hogw = min(hamp, hcrit) + hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution + + coef_h2 = kxridge * rhohm * bnv * umag + + taulin = coef_h2 * hamp*hamp + tauhcr = coef_h2 * hcrit*hcrit + + IF (fr < frlin ) then + tauogw = taulin + taulee = 0.0 + taumtb = 0.0 + else if (fr .ge. frlin ) then + tauogw = tauhcr + taulin = coef_h2 * hamp*hamp + taumtb = tau_izb ! integrated form MTB +! +! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? +! + frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] + BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] + + if ( fr <= frlin2 ) then + Betaf= 2.*BetaMax*(frNorm-1.0) + taulee = (1. + Betaf )*taulin - tauhcr + else if ( (fr > frlin2).and.(fr <= frlin3))then + Betaf=-1.+ 1./frnorm/frnorm + & + (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) + taulee = (1. + Betaf )*taulin - tauhcr +!============== +! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) +! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) +! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) +! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) +! +!============== + else + taulee = 0.0 + hdsw = 0.0 + endif + ENDIF + + tautot = tauogw + taulee + taumtb*0. + + IF (taulee > 0.0 ) THEN + + hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge +! +! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves +! make "empirical" height above elvp that may represent DSW-wave breaking & trapping +! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge +! + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) ! kph marks the low-level of wave solutions + klwb = kph ! klwb above blocking marks wave-breaking + kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level + + if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) + + udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) + hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) + umd(krefj) = udir + + udir = max(ui(kph)*xn +vi(kph)*yn, velmin) + hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) + umd(kph) = udir + ! what we can put between k =[kph:krefj] + phmkz(:) = 0.0 ! + phmkz(kph-1) = fr ! initial Phase of the low-level wave +! +! now transfer tau_layer => tau_level assuming tau_layer = tau_level +! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT +! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 +! + loop_lwb_otr: do k=kph+1, krefj ! levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, dw2min) -c2f2 + + + if (umd2 <= 0.0) then +! +! critical layer +! + klwb = k + kotr = k + exit loop_lwb_otr + endif + + mkz2 = bn2i(k)/umd2 - kx2 + + if ( mkz2 >= mkz2min ) then +! +! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 +! at finest vertical resolution we can meet "abrupt" mkz +! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km +! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) +! + mkz = sqrt(mkz2) + hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) + udswz = hdswz *bn2i(k) +!=========================================================================================== +!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 +! +! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz +! by k = krefj tautot = tauogw(krefj) +!=========================================================================================== + if (do_klwb_phase) then + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then + klwb = min(k, krefj) + exit loop_lwb_otr + endif + endif + else ! mkz2 < mkz2min + kotr = k ! trapped/reflected waves / + exit loop_lwb_otr + endif + enddo loop_lwb_otr +! +! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee +! tau_trapped ??? +! + if (do_klwb_phase) then + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif +! +! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) +! more complicated is dissipative saturation pdtrans =/= constant +! + if (do_dtrans) then + do k=kph, krefj + tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) + drlee(k) = -tau_src(k)/rho(k) * pdtrans + enddo + endif + + + ENDIF !taulee > 0.0 + + + endif !strver +! + +!========================================================================= + if (strver == 'gfs_2018' .or. strver == 'kd_2005') then +!========================================================================= +! +! orowaves: OGW+DSW/Lee +! + efact = (oa + 2.0) ** (ceofrc*fr) + efact = min( max(efact,efmin), efmax ) + coefm = (1. + clx) ** (oa+1.) + + kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx + kxlinv = coefm * cleff + tem = fr * fr * oc + gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 +!========================================================================= +! source fluxes: taulin, taufrb +!========================================================================= + tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact + + coef_h2 = kxlinv *rhohm * bnv*umag + taulin = coef_h2 *hamp*hamp + hcrit = fcrit_gfs*umag/bnv + tauhcr = coef_h2 *hcrit*hcrit + + IF (fr <= fcrit_gfs) then + tauogw = taulin + tautot = taulin + taulee = 0. + drlee(:) = 0. + ELSE !fr > fcrit_gfs + tauogw = tauhcr + taulee = max(tautot - tauogw, 0.0) + if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) +! approximate drlee(k) between [izb, klwb] +! find klwb and decrease taulee(izb) => taulee(klwb) = 0. +! above izb tau + if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then + + mkz = sqrt(mkz2) + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) + phmkz(:) = 0.0 + klwb = max(izb, 1) + kotr = levs+1 + phmkz(kph-1) = fr ! initial Phase of the Lee-OGW + + loop_lwb_gfs18: do k=kph, levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, velmin*velmin) + mkz2 = bn2i(k)/umd2 - kx2 + if ( mkz2 > mkz2min ) then + mkz = sqrt(mkz2) + frlocal = max(hdsw*bvi(k)/umd(k), frlwb) + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k + else + kotr = k + exit loop_lwb_gfs18 + endif + enddo loop_lwb_gfs18 +! +! + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 + ENDIF !fr > fcrit_gfs + + + ENDIF !strbase='gfs2017' .or. strbase='kd_2005' + + +! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge +! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' +! + end subroutine ugwp_taub_oro +! +!-------------------------------------- +! +! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & +! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & +! xn, yn, umag, drtau, kdis_oro) + + subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & + kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + xn, yn, umag, drtau, kdis) + + use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav + use cires_ugwp_module_v1, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 + use cires_ugwp_module_v1, only : kvg, ktg, krad, kion + use ugwp_oro_init_v1, only : coro , fcrit_sm , fcrit_sm2 + implicit none +! + integer, intent(in) :: krefj, levs + real , intent(in) :: tauogw, tautot, kxw + real , intent(in) :: fcor + + real , dimension(levs+1) :: tau_src + + real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm + real, dimension(levs+1), intent(in) :: zpi, pmid, pint + real , intent(in) :: xn, yn, umag + real , intent(in) :: kxridge + + + real, dimension(levs), intent(out) :: drtau, kdis +! +! locals +! + real :: uref, udir, uf2, ufd, uf2p + real, dimension(levs+1) :: tauz + real, dimension(levs) :: rho + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + + integer :: i, j, k, kcrit, kref + real :: kx2, kx2w, kxs + real :: mkzm, mkz, dkz, mkz2, ch, kzw3 + real :: wfdM, wfdT, wfiM, wfiT + real :: fdis, mkzi, keff_m, keff_t + real :: betadis, betam, betat, cdfm, cdft + real :: fsat, hsat, hsat2, kds , c2f2 + + drtau(1:levs) = 0.0 + kdis (1:levs) = 0.0 + + ch = coro + + kx2w = kxw*kxw + kx2 = kxridge*kxridge + if( kx2 < kx2w ) kx2 = kx2w + kxs = sqrt(kx2) + c2f2 = fcor*fcor/kx2 +! +! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) +! +! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) +!=============================================================================== +! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 +! rotational/non-hyrostatic effects are important only for high-res runs +! Udir = 0, Udir < 0 are not +! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz +! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) +! stochastic "tauogw'-setup+ sigma_tau ; +! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves +! target is to get "multiple"-saturation levels for OGWs +!=============================================================================== + tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode + ! sign of tauz > 0...and its attenuate with Z + k = krefj + uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves + uf2 = uref*uref - c2f2 + if (uf2 > 0) then + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2.gt.0) then + mkzm = sqrt(mkz2) + else + return ! wave reflection mkz2 <=0. + endif + else + return ! wave absorption uf2 <= 0. + endif +! +! upward solver for single "mode" with tauz(levs+1) =0. at the top +! + kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer + kcrit = levs + do k= krefj+1, levs +! +! 2D-wave propagation along reference-wind direction +! udir = 0 critical wind for coro =0 +! cdop = -uref .... upwind waves travel against MF +! + udir = ui(k)*xn +vi(k)*yn + uf2 = udir*udir - c2f2 + + + if (uf2 < dw2min .or. udir <= 0.0) then + kcrit =K + tauz(kcrit:levs) = 0. + exit ! vert-level loop + endif +! +! wave-based solution +! + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2 > 0) then + mkzm = sqrt(mkz2) +! +! do dissipative flux vs saturation: kvg, ktg, krad, kion +! + kzw3 = mkzm*mkz2 +! + keff_m = kvg(k)*mkz2 + kion(k) +! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol + keff_t = ktg(k)*mkz2 + krad(k) +! +! + uf2p = uf2 + 2.0*c2f2 + betadis = uf2/uf2p + betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw + betaT = 1.0- BetaM + +! +!imaginary frequencies of momentum and heat with "kds at (k-1) level" +! + wfiM = kds*mkz2 + keff_m + wfiT = kds*mkz2 + keff_t +! + cdfm = sqrt(uf2)*kxs + cdft = abs(udir)*kxs + wfdM = wfiM/cdfm *BetaM + wfdT = wfiT/Cdft *BetaT + mkzi = 2.0*mkzm*(wfdM+wfdT) + + fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) + tauz(k) = fdis + hsat2 = fcrit_sm2 * uf2 *bn2i(k) + fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) + if (fdis > fsat) then + tauz(k) = min(fsat, tauz(k-1)) +!================================================================= +! two definitions for eddy mixing of MF: +! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 +! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 +!================================================================= + kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) + kdis(k) = kds + endif + else + tauz(k:levs) = 0. ! wave is reflected above + kds = 0. + endif + enddo + + do k=krefj+1, kcrit + drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) + enddo +! +! + end subroutine ugwp_oro_lsatdis +! +! + subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & + utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common_v1 , only : rcpd2 + use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none +! + integer :: im, levs + real(kind_phys), dimension(im, levs) :: u, v, zmid + real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl + real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: sgh = 30. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 +! + + do i=1, im + + zdec = max(n_tofd*sigflt(i), zpbl(i)) + zdec = min(ze_tofd, zdec) + rzdec = 1.0/zdec + sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) + + do k=1, levs + zmet = zmid(i,k) + if (zmet > ztop_tofd) cycle + ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) + umag = sqrt(ekin) + zarg = zmet*rzdec + zexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp + utofd(i,k) = -krf*u(i,k) + vtofd(i,k) = -krf*v(i,k) + epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re + krf_tofd(i,k) = krf + enddo + enddo +! + end subroutine ugwp_tofd +! +! + subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common_v1 , only : rcpd2 + use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none + integer :: levs + real(kind_phys), dimension(levs) :: u, v, zmid + real(kind_phys) :: sigflt, elvmax, zpbl, zsurf + real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: sghmax = 5. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed 18 km + rzdec = 1.0/zdec + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + ekin = u(k)*u(k) + v(k)*v(k) + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf + enddo +! + end subroutine ugwp_tofd1d + + +end module cires_vert_orodis_v1 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 58872057e..de1b147a9 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -122,6 +122,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + end if else write(errmsg,'(*(a))') "Logic error: cires_ugwp_init called but do_ugwp is false and cdmbgwd(3) <= 0" errflg = 1 @@ -192,6 +193,9 @@ end subroutine unified_ugwp_finalize !! @{ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & lonr, oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss,dx,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl,dusfc_ss, & + dvsfc_ss,dusfc_fd,dvsfc_fd,dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,br1,hpbl,slmsk, & do_tofd, ldiag_ugwp, cdmbgwd, jdat, xlat, xlat_d, sinlat, coslat, area, & ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & @@ -202,7 +206,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only, errmsg, errflg) + do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) implicit none @@ -331,8 +335,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & ol4ss,theta,sigma,gamma,elvmax,dtaux2d_ls, & dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss, & - dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,dusfc, & - dvsfc,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,dusfcg, & + dvsfcg,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & con_fvirt,con_pi,lonr, & @@ -363,7 +367,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & clx, theta, sigma, gamma, elvmax, & sgh30, DUSFCg, DVSFCg, xlat_d, sinlat, coslat, & - spgrid,cdmbgwd(1:2), me, master, rdxzb, & + area,cdmbgwd(1:2), me, master, rdxzb, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & du3dt_mtb, du3dt_ogw, du3dt_tms) From 8f8dd2e8e00145027568e3e34b8bd5dc2fe680ec Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 4 Sep 2020 08:53:05 -0600 Subject: [PATCH 17/45] physics/tracer_sanitizer.meta: add [ccpp-table-properties] section --- physics/tracer_sanitizer.meta | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/physics/tracer_sanitizer.meta b/physics/tracer_sanitizer.meta index 582823fdb..0378911ed 100644 --- a/physics/tracer_sanitizer.meta +++ b/physics/tracer_sanitizer.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = tracer_sanitizer + type = scheme + dependencies = machine.F + +######################################################################## + [ccpp-arg-table] name = tracer_sanitizer_run type = scheme From a05e096db0c1176140ef49032a71178c4cbe7089 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 4 Sep 2020 21:43:01 +0000 Subject: [PATCH 18/45] Some progress made but still the model crashes. The changes include: 1. Use the same logic as in GFS_surface_composites_pre_run to define variables: land, icy and wet. 2. Use real stype and vtype that are defined in the INIT step. The land points are initialized now correctly, but the crash happens in the GF scheme presumably over water or ice point. --- physics/module_sf_ruclsm.F90 | 21 ++-- physics/sfc_drv_ruc.F90 | 233 +++++++++++++++++++++++------------ physics/sfc_drv_ruc.meta | 75 +++++++---- 3 files changed, 212 insertions(+), 117 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index e02e1edb0..1a7037cf7 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7075,6 +7075,7 @@ SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & errflag = 0 DO j = jts,jtf DO i = its,itf + IF ( ISLTYP( i,j ) .LT. 0 ) THEN errflag = 1 print *, & @@ -7128,23 +7129,23 @@ SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & endif ENDDO - elseif(icy(i) .and. .not. frac_grid ) then + elseif( icy(i) .and. .not. frac_grid ) then !-- ice DO L=1,NZS smfr3d(i,l,j)=1. sh2o(i,l,j)=0. mavail(i,j) = 1. ENDDO - endif ! land - !else -!-- for water ISLTYP=14 - ! DO L=1,NZS - ! smfr3d(i,l,j)=0. - ! sh2o(i,l,j)=1. - ! mavail(i,j) = 1. - ! ENDDO - !endif + elseif( .not. frac_grid) then + !-- water ISLTYP=14 + DO L=1,NZS + smfr3d(i,l,j)=0. + sh2o(i,l,j)=1. + mavail(i,j) = 1. + ENDDO + + endif ! land !ENDIF ENDDO diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index db1ad00b4..3b84f6bf9 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -16,6 +16,8 @@ module lsm_ruc public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize + real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, epsln = 1.0d-10 + contains !> This subroutine calls set_soilveg_ruc() to specify vegetation and soil parameters for @@ -26,9 +28,10 @@ module lsm_ruc subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & flag_restart, flag_init, & im, lsoil_ruc, lsoil, kice, nlev, & ! in - lsm_ruc, lsm, & ! in - soiltyp, vegtype, frac_grid, land, icy, & ! in - fice, tsfc_lnd, tsfc_wat, tice, & + lsm_ruc, lsm, slmsk, landfrac, & ! in + stype, vtype, frac_grid, & ! in + flag_cice, min_seaice, min_lakeice, & + fice, tsfc_lnd, tsfc_wat, & tg3, smc, slc, stc, & ! in smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, wetness, & ! out @@ -46,19 +49,22 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & integer, intent(in) :: kice integer, intent(in) :: nlev integer, intent(in) :: lsm_ruc, lsm - integer,dimension(im),intent(inout) :: soiltyp, vegtype - logical, dimension(im), intent(in) :: land, icy - real (kind=kind_phys), dimension(im), intent(in ) :: fice + real (kind=kind_phys), dimension(im), intent(in ) :: slmsk + real (kind=kind_phys), dimension(im), intent(in ) :: landfrac + real (kind=kind_phys), dimension(im), intent(in ) :: stype + real (kind=kind_phys), dimension(im), intent(in ) :: vtype + logical, dimension(im), intent(in ) :: flag_cice + real (kind=kind_phys), intent(in ) :: min_lakeice, min_seaice real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_lnd real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_wat - real (kind=kind_phys), dimension(im), intent(in ) :: tice real (kind=kind_phys), dimension(im), intent(in) :: tg3 real (kind=kind_phys), dimension(im,lsoil), intent(in) :: smc,slc,stc ! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: fice real (kind=kind_phys), dimension(im), intent(inout) :: wetness real (kind=kind_phys), dimension(im), intent(inout) :: smcref2, smcwlt2 @@ -73,31 +79,32 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! --- local integer :: ipr, i, k logical :: debug_print + logical, dimension(im) :: land, icy, wet + integer, dimension(im) :: soiltyp, vegtype + real (kind=kind_phys), dimension(im) :: frland ! Initialize CCPP error handling variables errmsg = '' errflg = 0 ipr = 10 - debug_print = .true. + debug_print = .false. !> - Call rucinit() to initialize soil/ice/water variables if ( debug_print) then write (0,*) 'RUC LSM initialization' write (0,*) 'lsoil_ruc, lsoil',lsoil_ruc, lsoil - write (0,*) 'noah soil temp',stc(:,1) - write (0,*) 'noah soil mois',smc(:,1) + write (0,*) 'me, isot, ivegsrc, nlunit ',me, isot, ivegsrc, nlunit + write (0,*) 'noah soil temp',stc(ipr,:) write (0,*) 'noah mois(ipr)',ipr,smc(ipr,:) - write (0,*) 'soiltyp=',soiltyp(:) - write (0,*) 'vegtype=',vegtype(:) - write (0,*) 'fice=',fice(:) - write (0,*) 'tice=',tice(:) - write (0,*) 'tsfc_lnd=',tsfc_lnd(:) - write (0,*) 'tsfc_wat=',tsfc_wat(:) - write (0,*) 'tg3=',tg3(:) - write (0,*) 'land=',land(:) - write (0,*) 'icy=',icy(:) + write (0,*) 'stype=',stype(ipr) + write (0,*) 'vtype=',vtype(ipr) + write (0,*) 'fice=',fice(ipr) + write (0,*) 'tsfc_lnd=',tsfc_lnd(ipr) + write (0,*) 'tsfc_wat=',tsfc_wat(ipr) + write (0,*) 'tg3=',tg3(ipr) + write (0,*) 'slmsk=',slmsk(ipr) write (0,*) 'flag_init =',flag_init write (0,*) 'flag_restart =',flag_restart endif @@ -105,13 +112,89 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !--- initialize soil vegetation call set_soilveg_ruc(me, isot, ivegsrc, nlunit) + soiltyp(:) = 0 + vegtype(:) = 0 + land (:) = .false. + icy (:) = .false. + wet (:) = .false. + + if (frac_grid) then ! fice is ice fraction wrt water area + do i=1,im + frland(i) = landfrac(i) + if (frland(i) > zero) land(i) = .true. + if (frland(i) < one) then + if (flag_cice(i)) then + if (fice(i) >= min_seaice) then + icy(i) = .true. + else + fice(i) = zero + endif + else + if (fice(i) >= min_lakeice) then + icy(i) = .true. + else + fice(i) = zero + endif + endif + if (fice(i) < one ) then + wet(i)=.true. ! some open ocean/lake water exists + end if + else + fice(i) = zero + endif + enddo + + else + + do i = 1, IM + frland(i) = zero + if (slmsk(i) == 0) then + wet(i) = .true. + fice(i) = zero + elseif (slmsk(i) == 1) then + land(i) = .true. + frland(i) = one + fice(i) = zero + else + icy(i) = .true. + if (fice(i) < one) then + wet(i) = .true. + endif + endif + enddo + + endif + + do i = 1, im ! i - horizontal loop + if( land(i) ) then + !-- land + soiltyp(i) = int( stype(i)+0.5 ) + vegtype(i) = int( vtype(i)+0.5 ) + elseif( icy(i) > 0. ) then + !-- ice + if (isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (ivegsrc == 1) then + vegtype(i) = 15 + elseif(ivegsrc == 2) then + vegtype(i) = 13 + endif + elseif ( wet(i) ) then + !-- water + if (soiltyp(i) < 1) soiltyp(i) = 14 + if (vegtype(i) < 1) vegtype(i) = 17 + endif + enddo + if( .not. flag_restart) then call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, isot, ivegsrc, nlunit, & ! in - lsm_ruc, lsm, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in frac_grid, land, icy, & ! in soiltyp, vegtype, fice, & ! in - tsfc_lnd, tsfc_wat, tice, tg3, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in smc, slc, stc, & ! in smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, & ! out @@ -400,6 +483,8 @@ subroutine lsm_ruc_run & ! inputs endif if(flag_init .and. iter==1) then + ! Initialize the RUC soil levels, needed for cold starts and warm starts + CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) xlai = 0. endif ! flag_init=.true.,iter=1 @@ -773,7 +858,7 @@ subroutine lsm_ruc_run & ! inputs znt(i,j) = zorl(i)/100. !if(debug_print) then - if(me==0 .and. i==ipr) then + !if(i==ipr) then write (0,*)'before RUC smsoil = ',smsoil(i,:,j), i,j write (0,*)'stsoil = ',stsoil(i,:,j), i,j write (0,*)'soilt = ',soilt(i,j), i,j @@ -849,25 +934,12 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'stsoil(i,:,j)=',i,j,stsoil(i,:,j) write (0,*)'smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) write (0,*)'keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'hfx(i,j) =',i,j,hfx(i,j) - write (0,*)'qfx(i,j) =',i,j,qfx(i,j) - write (0,*)'lh(i,j) =',i,j,lh(i,j) - write (0,*)'infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'runoff2(i,j) =',i,j,runoff2(i,j) write (0,*)'acrunoff(i,j) =',i,j,acrunoff(i,j) - write (0,*)'sfcexc(i,j) =',i,j,sfcexc(i,j) - write (0,*)'acceta(i,j) =',i,j,acceta(i,j) - write (0,*)'ssoil(i,j) =',i,j,ssoil(i,j) - write (0,*)'snfallac(i,j) =',i,j,snfallac(i,j) write (0,*)'acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'snomlt(i,j) =',i,j,snomlt(i,j) write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) write (0,*)'rdlai2d =',rdlai2d - endif + !endif !endif !> - Call RUC LSM lsmruc(). @@ -906,7 +978,7 @@ subroutine lsm_ruc_run & ! inputs & its,ite, jts,jte, kts,kte ) !if(debug_print) then - if(me==0.and.i==ipr) then + !if(i==ipr) then write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j write (0,*)'after sneqv(i,j) =',i,j,sneqv(i,j) write (0,*)'after snowh(i,j) =',i,j,snowh(i,j) @@ -941,7 +1013,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'after snfallac(i,j) =',i,j,snfallac(i,j) write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) write (0,*)'after snomlt(i,j) =',i,j,snomlt(i,j) - endif + !endif !endif @@ -1109,11 +1181,10 @@ end subroutine lsm_ruc_run !>\ingroup lsm_ruc_group !! This subroutine contains RUC LSM initialization. subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, isot, ivegsrc, nlunit, & ! in - lsm_ruc, lsm, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in frac_grid, land, icy, & ! in soiltyp, vegtype, fice, & ! in - tskin_lnd, tskin_wat, tice, tg3, & ! !in + tskin_lnd, tskin_wat, tg3, & ! !in smc, slc, stc, & ! in smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, & ! out @@ -1124,14 +1195,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in logical, intent(in ) :: restart integer, intent(in ) :: lsm integer, intent(in ) :: lsm_ruc - integer, intent(in ) :: isot - integer, intent(in ) :: ivegsrc, nlunit integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil logical, intent(in ) :: frac_grid logical, dimension(im), intent(in ) :: land, icy - real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat, tice + real (kind=kind_phys), dimension(im), intent(in ) :: slmsk + real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat real (kind=kind_phys), dimension(im), intent(inout) :: smcref2 real (kind=kind_phys), dimension(im), intent(inout) :: smcwlt2 real (kind=kind_phys), dimension(im), intent(in ) :: tg3 @@ -1165,7 +1235,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp real (kind=kind_phys), dimension( 1:im , 1:1 ) :: mavail - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: xice real (kind=kind_phys), dimension( 1:im , 1:1 ) :: sst real (kind=kind_phys), dimension( 1:im , 1:1 ) :: landmask real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tsk @@ -1274,15 +1343,15 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in endif - !if(debug_print) then + if(debug_print) then write (0,*)'smc(ipr,:) ==', ipr, smc(ipr,:) write (0,*)'stc(ipr,:) ==', ipr, stc(ipr,:) - !write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) - !write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) write (0,*)'tskin_lnd(:)=',tskin_lnd(:) write (0,*)'tskin_wat(:)=',tskin_wat(:) + write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) + write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) write (0,*)'its,ite,jts,jte ',its,ite,jts,jte - !endif + endif do j=jts,jte ! @@ -1290,16 +1359,15 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sst(i,j) = tskin_wat(i) tbot(i,j)= tg3(i) - ! land only version - if (land(i)) then - tsk(i,j) = tskin_lnd(i) ivgtyp(i,j)=vegtype(i) isltyp(i,j)=soiltyp(i) - !ivgtyp(i,j )= 12 - !isltyp(i,j) = 3 + if (land(i) .or. icy(i)) then + !-- land or ice + tsk(i,j) = tskin_lnd(i) landmask(i,j)=1. - xice(i,j)=0. else + !-- water + tsk(i,j) = tskin_wat(i) landmask(i,j)=0. endif ! land(i) @@ -1311,15 +1379,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte ! do i=its,ite ! i = horizontal loop - if (land(i)) then - st_input(i,1,j)=tsk(i,j) sm_input(i,1,j)=0. do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(swi_init) then + if(land(i) .and. swi_init) then !--- initialize smcwlt2 and smcref2 with Noah values smcref2 (i) = REFSMCnoah(soiltyp(i)) smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) @@ -1334,8 +1400,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sm_input(i,k,j)=0. enddo - endif ! land(i) - enddo ! i - horizontal loop enddo ! jme @@ -1360,17 +1424,21 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite if (land(i)) then - do k=1,lsoil_ruc + do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture - if(swi_init) then + if(swi_init) then soilm(i,k,j)= dumsm(i,k,j) * & (refsmc(isltyp(i,j))-drysmc(isltyp(i,j))) & + drysmc(isltyp(i,j)) - else - soilm(i,k,j)= dumsm(i,k,j) - endif + else + soilm(i,k,j)= dumsm(i,k,j) + endif soiltemp(i,k,j) = dumt(i,k,j) - enddo + enddo ! k + elseif (icy(i)) then + do k=1,lsoil_ruc + soiltemp(i,k,j) = dumt(i,k,j) + enddo ! k endif ! land(i) enddo enddo @@ -1469,33 +1537,38 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in ! Initialize liquid and frozen soil moisture from total soil moisture ! and soil temperature, and also soil moisture availability in the top ! layer - !call ruclsminit( debug_print, frac_grid, land, icy, & - ! lsoil_ruc, isltyp, ivgtyp, mavail, & - ! soilh2o, smfr, soiltemp, soilm, & - ! ims,ime, jms,jme, kms,kme, & - ! its,ite, jts,jte, kts,kte ) + + call ruclsminit( debug_print, frac_grid, land, icy, & + lsoil_ruc, isltyp, ivgtyp, mavail, & + soilh2o, smfr, soiltemp, soilm, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) do j=jts,jte do i=its,ite if (land(i)) then - wetness(i) = soilm(i,1,j)/0.5 - !wetness(i) = mavail(i,j) + wetness(i) = mavail(i,j) do k = 1, lsoil_ruc smois(i,k) = soilm(i,k,j) tslb(i,k) = soiltemp(i,k,j) - sh2o(i,k) = soilm(i,k,j) - smfrkeep(i,k) = soilm(i,k,j) - !sh2o(i,k) = soilh2o(i,k,j) - !smfrkeep(i,k) = smfr(i,k,j) + sh2o(i,k) = soilh2o(i,k,j) + smfrkeep(i,k) = smfr(i,k,j) enddo + elseif (icy(i)) then + wetness (i) = 1. + do k = 1, lsoil_ruc + smois(i,k) = 1. + tslb(i,k) = soiltemp(i,k,j) + sh2o(i,k) = 0. + smfrkeep(i,k) = 1. + enddo endif ! land(i) enddo enddo - ! For non-land points, set RUC LSM fields to input (Noah or RUC) fields if (.not. frac_grid) then do i=1,im - if (.not.land(i)) then + if (.not.land(i) .and. .not.icy(i)) then wetness (i) = 1. do k=1,min(lsoil,lsoil_ruc) smois(i,k) = smc(i,k) diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 730bcd8c0..3441111e5 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -113,20 +113,40 @@ type = integer intent = in optional = F -[soiltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stype] + standard_name = soil_type_classification_real + long_name = soil type for lsm units = index dimensions = (horizontal_dimension) - type = integer - intent = inout + type = real + kind = kind_phys + intent = in optional = F -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell +[vtype] + standard_name = vegetation_type_classification_real + long_name = vegetation type for lsm units = index dimensions = (horizontal_dimension) - type = integer + type = real + kind = kind_phys intent = inout optional = F [frac_grid] @@ -137,20 +157,30 @@ type = logical intent = in optional = F -[land] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice units = flag dimensions = (horizontal_dimension) type = logical intent = in optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_dimension) - type = logical +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = ??? + dimensions = () + type = real + kind = kind_phys intent = in optional = F [fice] @@ -180,15 +210,6 @@ kind = kind_phys intent = inout optional = F -[tice] - standard_name = sea_ice_temperature_interstitial - long_name = sea ice surface skin temperature use as interstitial - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F [tg3] standard_name = deep_soil_temperature long_name = deep soil temperature From f868281cb4f8359869eaa11f530a0e081127c125 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 8 Sep 2020 19:05:17 +0000 Subject: [PATCH 19/45] Removed prints and some clean-up. --- physics/sfc_drv_ruc.F90 | 50 +++++++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 3b84f6bf9..6debf4522 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -209,7 +209,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & enddo ! i endif ! flag_restart -!-- end of initialization + !-- end of initialization if ( debug_print) then write (0,*) 'ruc soil tslb',tslb(:,1) @@ -857,8 +857,8 @@ subroutine lsm_ruc_run & ! inputs z0(i,j) = zorl(i)/100. znt(i,j) = zorl(i)/100. - !if(debug_print) then - !if(i==ipr) then + if(debug_print) then + if(i==ipr) then write (0,*)'before RUC smsoil = ',smsoil(i,:,j), i,j write (0,*)'stsoil = ',stsoil(i,:,j), i,j write (0,*)'soilt = ',soilt(i,j), i,j @@ -939,8 +939,8 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) write (0,*)'rdlai2d =',rdlai2d - !endif - !endif + endif + endif !> - Call RUC LSM lsmruc(). call lsmruc( delt, flag_init, flag_restart, kdt, iter, nsoil, & @@ -977,8 +977,8 @@ subroutine lsm_ruc_run & ! inputs & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) - !if(debug_print) then - !if(i==ipr) then + if(debug_print) then + if(i==ipr) then write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j write (0,*)'after sneqv(i,j) =',i,j,sneqv(i,j) write (0,*)'after snowh(i,j) =',i,j,snowh(i,j) @@ -1013,8 +1013,8 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'after snfallac(i,j) =',i,j,snfallac(i,j) write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) write (0,*)'after snomlt(i,j) =',i,j,snomlt(i,j) - !endif - !endif + endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -1320,8 +1320,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in flag_soil_levels = 1 ! =1 for input from RUC LSM else ! for Noah input set smadj and swi_init to .true. - smadj = .false. - swi_init = .false. + smadj = .true. + swi_init = .true. flag_soil_layers = 1 ! =1 for input from the Noah LSM flag_soil_levels = 0 ! =1 for input from RUC LSM endif @@ -1358,18 +1358,18 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do i=its,ite ! i = horizontal loop sst(i,j) = tskin_wat(i) - tbot(i,j)= tg3(i) - ivgtyp(i,j)=vegtype(i) - isltyp(i,j)=soiltyp(i) + tbot(i,j) = tg3(i) + ivgtyp(i,j) = vegtype(i) + isltyp(i,j) = soiltyp(i) if (land(i) .or. icy(i)) then !-- land or ice tsk(i,j) = tskin_lnd(i) landmask(i,j)=1. - else - !-- water + else + !-- water tsk(i,j) = tskin_wat(i) landmask(i,j)=0. - endif ! land(i) + endif ! land(i) enddo enddo @@ -1382,13 +1382,19 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in st_input(i,1,j)=tsk(i,j) sm_input(i,1,j)=0. + !--- initialize smcwlt2 and smcref2 with Noah values + if(land(i)) then + smcref2 (i) = REFSMCnoah(soiltyp(i)) + smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + else + smcref2 (i) = 1. + smcwlt2 (i) = 0. + endif + do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) if(land(i) .and. swi_init) then - !--- initialize smcwlt2 and smcref2 with Noah values - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else @@ -1579,14 +1585,14 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in enddo endif ! frac_grid - !if(debug_print) then + if(debug_print) then do i=1,im write (0,*)'End of RUC LSM initialization' write (0,*)'tslb(i)=',i,land(i),icy(i),tslb(i,:) write (0,*)'smois(i)=',i,land(i),icy(i),smois(i,:) write (0,*)'wetness(i)=',i,land(i),icy(i),wetness(i) enddo - !endif ! debug_print + endif ! debug_print end subroutine rucinit From 088fcd4a5436adde3bf6297568f2904b8e65dc71 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 9 Sep 2020 14:48:45 +0000 Subject: [PATCH 20/45] 1st success -- Sept. 9 --- physics/cires_ugwp_initialize_v1.F90 | 16 +- physics/cires_ugwp_module_v1.F90 | 6 +- physics/unified_ugwp.meta | 332 +++++++++++++-------------- 3 files changed, 177 insertions(+), 177 deletions(-) diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 index 174a871d1..ef6c2c7d1 100644 --- a/physics/cires_ugwp_initialize_v1.F90 +++ b/physics/cires_ugwp_initialize_v1.F90 @@ -54,7 +54,7 @@ end module ugwp_common_v1 !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) use ugwp_common_v1, only : pih @@ -139,10 +139,10 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf ! 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) - end subroutine init_global_gwdis + end subroutine init_global_gwdis_v1 ! ! - subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + subroutine rf_damp_init_v1(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) implicit none integer :: levs @@ -172,7 +172,7 @@ subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) endif enddo - end subroutine rf_damp_init + end subroutine rf_damp_init_v1 ! ======================================================================== ! Part 2 - sources ! wave sources @@ -789,11 +789,11 @@ end module ugwp_wmsdis_init_v1 ! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) ! !========================================================================= - subroutine init_dspdis + subroutine init_dspdis_v1 implicit none - end subroutine init_dspdis + end subroutine init_dspdis_v1 - subroutine init_adodis + subroutine init_adodis_v1 implicit none - end subroutine init_adodis + end subroutine init_adodis_v1 diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 index dc586c6bd..a25854097 100644 --- a/physics/cires_ugwp_module_v1.F90 +++ b/physics/cires_ugwp_module_v1.F90 @@ -302,10 +302,10 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & launch_level = max(k-1, 5) ! above 5-layers from the surface ! -! Part-1 :init_global_gwdis +! Part-1 :init_global_gwdis_v1 ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) - call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + call init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + call rf_damp_init_v1 (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) ! ! Part-2 :init_SOURCES_gws ! diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 5c0eb458b..e45625e9e 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -51,6 +51,12 @@ kind = len=* intent = in optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer [lonr] standard_name = number_of_equatorial_longitude_points long_name = number of global points in x-dir (i) along the equator @@ -111,12 +117,6 @@ kind = kind_phys intent = in optional = F -[jdat] - standard_name = forecast_date_and_time - long_name = current forecast date and time - units = none - dimensions = (8) - type = integer [cgwf] standard_name = multiplication_factors_for_convective_gravity_wave_drag long_name = multiplication factor for convective GWD @@ -261,14 +261,6 @@ [ccpp-arg-table] name = unified_ugwp_run type = scheme -[do_ugwp] - standard_name = do_ugwp - long_name = flag to activate CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F [me] standard_name = mpi_rank long_name = MPI rank of current process @@ -421,6 +413,141 @@ kind = kind_phys intent = inout optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[varss] + standard_name = standard_deviation_of_subgrid_orography_small_scale + long_name = standard deviation of subgrid orography small scale + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oc1ss] + standard_name = convexity_of_subgrid_orography_small_scale + long_name = convexity of subgrid orography small scale + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oa4ss] + standard_name = asymmetry_of_subgrid_orography_small_scale + long_name = asymmetry of subgrid orography small scale + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4ss] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height small scale + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F [dtaux2d_ls] standard_name = x_momentum_tendency_from_large_scale_gwd long_name = x momentum tendency from large scale gwd @@ -493,60 +620,33 @@ kind = kind_phys intent = out optional = F -[clx] - standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height - long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height - units = frac - dimensions = (horizontal_dimension,4) - type = real - kind = kind_phys - intent = in - optional = F -[oa4] - standard_name = asymmetry_of_subgrid_orography - long_name = asymmetry of subgrid orography +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface units = none - dimensions = (horizontal_dimension,4) + dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[varss] - standard_name = standard_deviation_of_subgrid_orography_small_scale - long_name = standard deviation of subgrid orography small scale +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness units = m dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[oc1ss] - standard_name = convexity_of_subgrid_orography_small_scale - long_name = convexity of subgrid orography small scale - units = none +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[oa4ss] - standard_name = asymmetry_of_subgrid_orography_small_scale - long_name = asymmetry of subgrid orography small scale - units = none - dimensions = (horizontal_dimension,4) - type = real - kind = kind_phys - intent = in - optional = F -[ol4ss] - standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale - long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height small scale - units = frac - dimensions = (horizontal_dimension,4) - type = real - kind = kind_phys - intent = in - optional = F [do_tofd] standard_name = turb_oro_form_drag_flag long_name = flag for turbulent orographic form drag @@ -572,6 +672,12 @@ kind = kind_phys intent = in optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer [xlat] standard_name = latitude long_name = grid latitude @@ -733,105 +839,8 @@ kind = kind_phys intent = out optional = F -[dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd - long_name = integrated x momentum flux from large scale gwd - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd - long_name = integrated y momentum flux from large scale gwd - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag - long_name = integrated x momentum flux from blocking drag - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag - long_name = integrated y momentum flux from blocking drag - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd - long_name = integrated x momentum flux from small scale gwd - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd - long_name = integrated y momentum flux from small scale gwd - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag - long_name = integrated x momentum flux from form drag - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag - long_name = integrated y momentum flux from form drag - units = Pa s - dimensions = (horizontal_dimension) - type = real - kind = kind_phys intent = out optional = F -[slmsk] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[br1] - standard_name = bulk_richardson_number_at_lowest_model_level - long_name = bulk Richardson number at the surface - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[hpbl] - standard_name = atmosphere_boundary_layer_thickness - long_name = PBL thickness - units = m - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [gw_dudt] standard_name = tendency_of_x_wind_due_to_ugwp long_name = zonal wind tendency due to UGWP @@ -1021,23 +1030,6 @@ kind = kind_phys intent = out optional = F -[dx] - standard_name = cell_size - long_name = size of the grid cell - units = m - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[gwd_opt] - standard_name = gwd_opt - long_name = flag to choose gwd scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -1277,6 +1269,14 @@ type = logical intent = in optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 3204a42d25317ae84cded60d8b10f4f79ea05097 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 10 Sep 2020 21:34:37 +0000 Subject: [PATCH 21/45] Bug fix -- Sept. 10 --- physics/drag_suite.F90 | 3 ++- physics/unified_ugwp.F90 | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 76c2a85aa..0b0ef03a0 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -199,8 +199,9 @@ subroutine drag_suite_run( & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & + & lprnt, ipr, rdxzb, dx, gwd_opt, & & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + & errmsg, errflg ) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index de1b147a9..cff34ab8c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -340,9 +340,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & con_fvirt,con_pi,lonr, & - cdmbgwd(1:2),me,master,do_gsl_drag_ls_bl, & - do_gsl_drag_ss,do_gsl_drag_tofd,lprnt,ipr,rdxzb,dx, & - gwd_opt,errmsg,errflg) + cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & + do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & + errmsg,errflg) else if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then From 5ee932a5c672a1654bda8b654c94845b893aba24 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Sun, 13 Sep 2020 03:03:40 +0000 Subject: [PATCH 22/45] Sept. 12 bug fix --- physics/unified_ugwp.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index cff34ab8c..203bf9c48 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -106,7 +106,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & write(errmsg,'(*(a))') "Logic error: Only one large-scale& &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& - do_gsl_drag_ls_bl,do_ugwp_v1 or& + &do_gsl_drag_ls_bl,do_ugwp_v1 or & &do_ugwp_v1_orog_only) can be chosen" errflg = 1 return @@ -117,16 +117,18 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return - if ( do_ugwp_v0 .and. (do_ugwp .or. cdmbgwd(3) > 0.0) ) then - if (do_ugwp .or. cdmbgwd(3) > 0.0) then + if ( do_ugwp_v0 ) then + ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) + if (cdmbgwd(3) > 0.0) then call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + else + write(errmsg,'(*(a))') "Logic error: cires_ugwp_mod_init called but & + &do_ugwp_v0 is true and cdmbgwd(3) <= 0" + errflg = 1 + return end if - else - write(errmsg,'(*(a))') "Logic error: cires_ugwp_init called but do_ugwp is false and cdmbgwd(3) <= 0" - errflg = 1 - return end if From 278b70660f5b53e6d34c97b7b467ed520737cac3 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 14 Sep 2020 15:49:25 +0000 Subject: [PATCH 23/45] Sept. 14 state --- physics/unified_ugwp.F90 | 7 +++++-- physics/unified_ugwp.meta | 16 ++++++++++++++++ 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 203bf9c48..aa9be0492 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -153,10 +153,11 @@ end subroutine unified_ugwp_init !! \htmlinclude unified_ugwp_finalize.html !! #endif - subroutine unified_ugwp_finalize(errmsg, errflg) + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) implicit none ! + logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -166,7 +167,9 @@ subroutine unified_ugwp_finalize(errmsg, errflg) if (.not.is_initialized) return - call cires_ugwp_finalize() + if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() + + if ( do_ugwp_v1 ) call cires_ugwp_finalize() is_initialized = .false. diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index e45625e9e..23610f99c 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -239,6 +239,22 @@ [ccpp-arg-table] name = unified_ugwp_finalize type = scheme +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6e33a576148174ac89559bbc0d44a3a32cc26f1e Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 14 Sep 2020 20:10:52 +0000 Subject: [PATCH 24/45] A syntax error is corrected. --- physics/sfc_drv_ruc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 6debf4522..8004bc7f9 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -170,7 +170,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !-- land soiltyp(i) = int( stype(i)+0.5 ) vegtype(i) = int( vtype(i)+0.5 ) - elseif( icy(i) > 0. ) then + elseif( icy(i) ) then !-- ice if (isot == 1) then soiltyp(i) = 16 From 985ca4fcf164a0c5cfb529faaf4b9b3cfdea4ecd Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 15 Sep 2020 19:16:05 +0000 Subject: [PATCH 25/45] Fractional grid is removed from the RUC soil initialization, since the goal here is just a vertical interpolation from 4-layer t0 9-level data. --- physics/module_sf_ruclsm.F90 | 22 ++--- physics/sfc_drv_ruc.F90 | 184 ++++++++++------------------------- physics/sfc_drv_ruc.meta | 70 ------------- 3 files changed, 61 insertions(+), 215 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 1a7037cf7..024f97772 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7022,7 +7022,7 @@ END SUBROUTINE SOILVEGIN !> This subroutine computes liquid and forezen soil moisture from the !! total soil moisture, and also computes soil moisture availability in !! the top soil layer. - SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & + SUBROUTINE RUCLSMINIT( debug_print, slmsk, & nzs, isltyp, ivgtyp, mavail, & sh2o, smfr3d, tslb, smois, & ims,ime, jms,jme, kms,kme, & @@ -7035,8 +7035,7 @@ SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - LOGICAL, INTENT(IN ) :: frac_grid - LOGICAL, DIMENSION( ims:ime), INTENT(IN ) :: land, icy + REAL, DIMENSION( ims:ime), INTENT(IN ) :: slmsk INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & @@ -7095,11 +7094,11 @@ SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & ! in Zobler classification isltyp=0 for water. Statsgo classification ! has isltyp=14 for water if (isltyp(i,j) == 0) isltyp(i,j)=14 - - if(land(i) ) then - !--- Computation of volumetric content of ice in soil - !--- and initialize MAVAIL + if(slmsk(i) == 1. ) then + !-- land + !-- Computate volumetric content of ice in soil + !-- and initialize MAVAIL DQM = MAXSMC (ISLTYP(I,J)) - & DRYSMC (ISLTYP(I,J)) REF = REFSMC (ISLTYP(I,J)) @@ -7129,24 +7128,23 @@ SUBROUTINE RUCLSMINIT( debug_print, frac_grid, land, icy, & endif ENDDO - elseif( icy(i) .and. .not. frac_grid ) then + elseif( slmsk(i) == 2.) then !-- ice + mavail(i,j) = 1. DO L=1,NZS smfr3d(i,l,j)=1. sh2o(i,l,j)=0. - mavail(i,j) = 1. ENDDO - elseif( .not. frac_grid) then + else !-- water ISLTYP=14 + mavail(i,j) = 1. DO L=1,NZS smfr3d(i,l,j)=0. sh2o(i,l,j)=1. - mavail(i,j) = 1. ENDDO endif ! land - !ENDIF ENDDO ENDDO diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 8004bc7f9..5370cd763 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -28,12 +28,9 @@ module lsm_ruc subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & flag_restart, flag_init, & im, lsoil_ruc, lsoil, kice, nlev, & ! in - lsm_ruc, lsm, slmsk, landfrac, & ! in - stype, vtype, frac_grid, & ! in - flag_cice, min_seaice, min_lakeice, & - fice, tsfc_lnd, tsfc_wat, & + lsm_ruc, lsm, slmsk, stype, vtype, & ! in + tsfc_lnd, tsfc_wat, & ! in tg3, smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, wetness, & ! out tsice, errmsg, errflg) @@ -42,7 +39,6 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & integer, intent(in) :: me, master, isot, ivegsrc, nlunit logical, intent(in) :: flag_restart logical, intent(in) :: flag_init - logical, intent(in) :: frac_grid integer, intent(in) :: im integer, intent(in) :: lsoil_ruc integer, intent(in) :: lsoil @@ -52,11 +48,8 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(im), intent(in ) :: slmsk - real (kind=kind_phys), dimension(im), intent(in ) :: landfrac real (kind=kind_phys), dimension(im), intent(in ) :: stype real (kind=kind_phys), dimension(im), intent(in ) :: vtype - logical, dimension(im), intent(in ) :: flag_cice - real (kind=kind_phys), intent(in ) :: min_lakeice, min_seaice real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_lnd real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_wat real (kind=kind_phys), dimension(im), intent(in) :: tg3 @@ -64,9 +57,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(im,lsoil), intent(in) :: smc,slc,stc ! --- in/out: - real (kind=kind_phys), dimension(im), intent(inout) :: fice real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im), intent(inout) :: smcref2, smcwlt2 ! --- out real (kind=kind_phys), dimension(im,lsoil_ruc), intent(out) :: sh2o, smfrkeep @@ -79,9 +70,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! --- local integer :: ipr, i, k logical :: debug_print - logical, dimension(im) :: land, icy, wet integer, dimension(im) :: soiltyp, vegtype - real (kind=kind_phys), dimension(im) :: frland ! Initialize CCPP error handling variables errmsg = '' @@ -100,7 +89,6 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & write (0,*) 'noah mois(ipr)',ipr,smc(ipr,:) write (0,*) 'stype=',stype(ipr) write (0,*) 'vtype=',vtype(ipr) - write (0,*) 'fice=',fice(ipr) write (0,*) 'tsfc_lnd=',tsfc_lnd(ipr) write (0,*) 'tsfc_wat=',tsfc_wat(ipr) write (0,*) 'tg3=',tg3(ipr) @@ -114,63 +102,9 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & soiltyp(:) = 0 vegtype(:) = 0 - land (:) = .false. - icy (:) = .false. - wet (:) = .false. - - if (frac_grid) then ! fice is ice fraction wrt water area - do i=1,im - frland(i) = landfrac(i) - if (frland(i) > zero) land(i) = .true. - if (frland(i) < one) then - if (flag_cice(i)) then - if (fice(i) >= min_seaice) then - icy(i) = .true. - else - fice(i) = zero - endif - else - if (fice(i) >= min_lakeice) then - icy(i) = .true. - else - fice(i) = zero - endif - endif - if (fice(i) < one ) then - wet(i)=.true. ! some open ocean/lake water exists - end if - else - fice(i) = zero - endif - enddo - - else - - do i = 1, IM - frland(i) = zero - if (slmsk(i) == 0) then - wet(i) = .true. - fice(i) = zero - elseif (slmsk(i) == 1) then - land(i) = .true. - frland(i) = one - fice(i) = zero - else - icy(i) = .true. - if (fice(i) < one) then - wet(i) = .true. - endif - endif - enddo - - endif do i = 1, im ! i - horizontal loop - if( land(i) ) then - !-- land - soiltyp(i) = int( stype(i)+0.5 ) - vegtype(i) = int( vtype(i)+0.5 ) - elseif( icy(i) ) then + if (slmsk(i) == 2.) then !-- ice if (isot == 1) then soiltyp(i) = 16 @@ -182,8 +116,10 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & elseif(ivegsrc == 2) then vegtype(i) = 13 endif - elseif ( wet(i) ) then - !-- water + else + !-- land or water + soiltyp(i) = int( stype(i)+0.5 ) + vegtype(i) = int( vtype(i)+0.5 ) if (soiltyp(i) < 1) soiltyp(i) = 14 if (vegtype(i) < 1) vegtype(i) = 17 endif @@ -192,11 +128,9 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & if( .not. flag_restart) then call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - frac_grid, land, icy, & ! in - soiltyp, vegtype, fice, & ! in + soiltyp, vegtype, & ! in tsfc_lnd, tsfc_wat, tg3, & ! in smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -1182,11 +1116,9 @@ end subroutine lsm_ruc_run !! This subroutine contains RUC LSM initialization. subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - frac_grid, land, icy, & ! in - soiltyp, vegtype, fice, & ! in + soiltyp, vegtype, & ! in tskin_lnd, tskin_wat, tg3, & ! !in smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -1198,12 +1130,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil - logical, intent(in ) :: frac_grid - logical, dimension(im), intent(in ) :: land, icy real (kind=kind_phys), dimension(im), intent(in ) :: slmsk real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat - real (kind=kind_phys), dimension(im), intent(inout) :: smcref2 - real (kind=kind_phys), dimension(im), intent(inout) :: smcwlt2 real (kind=kind_phys), dimension(im), intent(in ) :: tg3 real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah @@ -1212,7 +1140,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, dimension(im), intent(inout) :: soiltyp integer, dimension(im), intent(inout) :: vegtype real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im), intent(in ) :: fice real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc @@ -1229,8 +1156,10 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in logical :: swi_init ! for initialization in terms of SWI (soil wetness index) integer :: flag_soil_layers, flag_soil_levels, flag_sst - real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm real (kind=kind_phys), dimension(1:lsoil_ruc) :: zs + real (kind=kind_phys), dimension(im) :: smcref2 + real (kind=kind_phys), dimension(im) :: smcwlt2 integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp @@ -1361,14 +1290,14 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vegtype(i) isltyp(i,j) = soiltyp(i) - if (land(i) .or. icy(i)) then - !-- land or ice - tsk(i,j) = tskin_lnd(i) - landmask(i,j)=1. - else + if (slmsk(i) == 0.) then !-- water tsk(i,j) = tskin_wat(i) landmask(i,j)=0. + else + !-- land or ice + tsk(i,j) = tskin_lnd(i) + landmask(i,j)=1. endif ! land(i) enddo @@ -1383,18 +1312,18 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sm_input(i,1,j)=0. !--- initialize smcwlt2 and smcref2 with Noah values - if(land(i)) then - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + if(slmsk(i) == 1.) then + smcref2 (i) = REFSMCnoah(soiltyp(i)) + smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) else - smcref2 (i) = 1. - smcwlt2 (i) = 0. + smcref2 (i) = 1. + smcwlt2 (i) = 0. endif do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(land(i) .and. swi_init) then + if(slmsk(i) == 1. .and. swi_init) then sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else @@ -1429,23 +1358,26 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (land(i)) then + if (slmsk(i) == 1.) then + !-- land do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture if(swi_init) then - soilm(i,k,j)= dumsm(i,k,j) * & + soilm(i,k,j) = dumsm(i,k,j) * & (refsmc(isltyp(i,j))-drysmc(isltyp(i,j))) & + drysmc(isltyp(i,j)) else - soilm(i,k,j)= dumsm(i,k,j) + soilm(i,k,j) = dumsm(i,k,j) endif soiltemp(i,k,j) = dumt(i,k,j) enddo ! k - elseif (icy(i)) then + else + !-- ice or water do k=1,lsoil_ruc + soilm(i,k,j) = 1. soiltemp(i,k,j) = dumt(i,k,j) enddo ! k - endif ! land(i) + endif ! land enddo enddo @@ -1467,7 +1399,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (land(i)) then + if (slmsk(i) == 1.) then ! initialize factor do k=1,lsoil_ruc @@ -1544,7 +1476,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in ! and soil temperature, and also soil moisture availability in the top ! layer - call ruclsminit( debug_print, frac_grid, land, icy, & + call ruclsminit( debug_print, slmsk, & lsoil_ruc, isltyp, ivgtyp, mavail, & soilh2o, smfr, soiltemp, soilm, & ims,ime, jms,jme, kms,kme, & @@ -1552,45 +1484,31 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (land(i)) then - wetness(i) = mavail(i,j) - do k = 1, lsoil_ruc - smois(i,k) = soilm(i,k,j) - tslb(i,k) = soiltemp(i,k,j) - sh2o(i,k) = soilh2o(i,k,j) - smfrkeep(i,k) = smfr(i,k,j) - enddo - elseif (icy(i)) then - wetness (i) = 1. - do k = 1, lsoil_ruc - smois(i,k) = 1. - tslb(i,k) = soiltemp(i,k,j) - sh2o(i,k) = 0. - smfrkeep(i,k) = 1. - enddo - endif ! land(i) + wetness(i) = mavail(i,j) + do k = 1, lsoil_ruc + smois(i,k) = soilm(i,k,j) + tslb(i,k) = soiltemp(i,k,j) + sh2o(i,k) = soilh2o(i,k,j) + smfrkeep(i,k) = smfr(i,k,j) + enddo enddo enddo - if (.not. frac_grid) then - do i=1,im - if (.not.land(i) .and. .not.icy(i)) then - wetness (i) = 1. - do k=1,min(lsoil,lsoil_ruc) - smois(i,k) = smc(i,k) - tslb(i,k) = stc(i,k) - sh2o(i,k) = slc(i,k) - enddo - endif - enddo - endif ! frac_grid + !do i=1,im + ! wetness (i) = 1. + ! do k=1,min(lsoil,lsoil_ruc) + ! smois(i,k) = smc(i,k) + ! tslb(i,k) = stc(i,k) + ! sh2o(i,k) = slc(i,k) + ! enddo + !enddo if(debug_print) then do i=1,im write (0,*)'End of RUC LSM initialization' - write (0,*)'tslb(i)=',i,land(i),icy(i),tslb(i,:) - write (0,*)'smois(i)=',i,land(i),icy(i),smois(i,:) - write (0,*)'wetness(i)=',i,land(i),icy(i),wetness(i) + write (0,*)'tslb(i)=',i,tslb(i,:) + write (0,*)'smois(i)=',i,smois(i,:) + write (0,*)'wetness(i)=',i,wetness(i) enddo endif ! debug_print diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 3441111e5..53bc48fdd 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -122,15 +122,6 @@ kind = kind_phys intent = in optional = F -[landfrac] - standard_name = land_area_fraction - long_name = fraction of horizontal grid area occupied by land - units = frac - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [stype] standard_name = soil_type_classification_real long_name = soil type for lsm @@ -149,49 +140,6 @@ kind = kind_phys intent = inout optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_dimension) - type = logical - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[fice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [tsfc_lnd] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -246,24 +194,6 @@ kind = kind_phys intent = in optional = F -[smcref2] - standard_name = threshold_volume_fraction_of_condensed_water_in_soil - long_name = soil moisture threshold - units = frac - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[smcwlt2] - standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point - long_name = soil water fraction at wilting point - units = frac - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [sh2o] standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model long_name = volume fraction of unfrozen soil moisture for lsm From f6fd209bc0199f5996a9f9092e87035d85d69c05 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 17 Sep 2020 23:18:12 +0000 Subject: [PATCH 26/45] Sept. 17 -- debugging --- physics/cires_ugwp.F90 | 33 +++++++++++++++++++++++ physics/gwdps.f | 6 +++++ physics/unified_ugwp.F90 | 57 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 95 insertions(+), 1 deletion(-) diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index df0116cd0..51f2b9504 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -77,6 +77,8 @@ subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return if (do_ugwp .or. cdmbgwd(3) > 0.0) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_init calling cires_ugwp_mod_init" call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -224,6 +226,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr errmsg = '' errflg = 0 + ! Temporary line + if ( me == master ) write (41,*) "ahoj svete: qgrs(:,:,1) = ", qgrs(:,:,1) + ! 1) ORO stationary GWs ! ------------------ ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality @@ -241,6 +246,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr zlwb(:) = 0. + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling GWDPS_V0" + call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & @@ -250,6 +258,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr else ! calling old GFS gravity wave drag as is + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run possibly about to call gwdps_run" + do k=1,levs do i=1,im Pdvdt(i,k) = 0.0 @@ -260,6 +271,8 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling gwdps_run" call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & ugrs, vgrs, tgrs, qgrs, & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & @@ -271,6 +284,17 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (errflg/=0) return endif + if ( me == master ) write (51,*) "ahoj svete: in cires after & + &gwdps_run ", kdt, " Pdudt = ", Pdudt + if ( me == master ) write (53,*) "ahoj svete: in cires after & + &gwdps_run ", kdt, " Pdvdt = ", Pdvdt + if ( me == master ) write (55,*) "ahoj svete: in cires after & + &gwdps_run ", kdt, " Pdtdt = ", Pdtdt + if ( me == master ) write (57,*) "ahoj svete: in cires after & + &gwdps_run ", kdt, " hprime =", hprime + if ( me == master ) write (59,*) "ahoj svete: in cires after & + &gwdps_run ", kdt, " elvmax =", elvmax + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 @@ -292,6 +316,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (cdmbgwd(3) > 0.0) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling slat_geos5_tamp" + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) @@ -330,6 +357,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo endif + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling fv3_ugwp_solv2_v0" + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -349,6 +379,9 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr else + ! Temporary line + if ( me == master ) print *, "ahoj svete: in cires_ugwp_run, didn't call ngw schemes" + do k=1,levs do i=1,im gw_dtdt(i,k) = Pdtdt(i,k) diff --git a/physics/gwdps.f b/physics/gwdps.f index b09413f02..63e9a7f7b 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -443,6 +443,9 @@ subroutine gwdps_run( & LCAP = KM LCAPP1 = LCAP + 1 ! +! Temporary line + if ( me == 0 ) print *, "ahoj svete: in gwdps_run, nmtvr =", nmtvr +! ! IF ( NMTVR == 14) then ! ---- for lm and gwd calculation points @@ -456,6 +459,9 @@ subroutine gwdps_run( & if (ipr == i) npr = npt ENDIF ENDDO + ! Temporary line + if (npt == 0 .and. me==0) print *, "ahoj svete: in gwdps_run ", + & kdt, " npt =", npt IF (npt == 0) RETURN ! No gwd/mb calculation done! ! ! if (lprnt) print *,' npt=',npt,' npr=',npr,' ipr=',ipr,' im=',im diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index aa9be0492..f97e218d1 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -120,6 +120,8 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v0 ) then ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) if (cdmbgwd(3) > 0.0) then + ! Temporary line + if ( me==master ) print *, "ahoj svete: in unified_ugwp_init calling cires_ugwp_mod_init" call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -133,6 +135,8 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v1 ) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_init calling cires_ugwp_init_v1" call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -295,6 +299,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. real(kind=kind_phys), parameter :: fw1_tau=1.0 + integer :: nmtvr_temp real(kind=kind_phys), dimension(:,:), allocatable :: tke real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem @@ -330,11 +335,25 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, zlwb(:) = 0. + ! Temporary lines + if ( me == master ) write (80,*) "ahoj svete: in unified beginning ", & + kdt, " elvmax =", elvmax + if ( me == master ) write (81,*) "ahoj svete: in unified beginning ", & + kdt, " sigma =", sigma + if ( me == master ) write (82,*) "ahoj svete: in unified beginning ", & + kdt, " oc =", oc + + + ! Temporary line + if ( me == master ) write (40,*) "ahoj svete: q1 = ", q1 + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd ) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling drag_suite_run" call drag_suite_run(im,levs,dvdt,dudt,dtdt,ugrs,vgrs,tgrs,q1, & kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & @@ -351,6 +370,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling gwdps_oro_v1" + ! Valery's TOFD ! topo paras ! w/ orographic effects @@ -378,6 +400,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_run getting ready to call something" + do k=1,levs do i=1,im Pdvdt(i,k) = 0.0 @@ -388,17 +413,37 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling gwdps_run" + + ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary + if ( nmtvr == 24 ) then ! gwd_opt = 2, 22, 3, or 33 + nmtvr_temp = 14 + else + nmtvr_temp = nmtvr + end if call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & ugrs, vgrs, tgrs, q1, & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & hprime, oc, oa4, clx, theta, sigma, gamma, & elvmax, dusfcg, dvsfcg, & con_g, con_cp, con_rd, con_rv, lonr, & - nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & + nmtvr_temp, cdmbgwd, me, lprnt, ipr, rdxzb, & errmsg, errflg) if (errflg/=0) return endif + if ( me == master ) write (52,*) "ahoj svete: in unified after & + &gwdps_run ", kdt, " Pdudt = ", Pdudt + if ( me == master ) write (54,*) "ahoj svete: in unified after & + &gwdps_run ", kdt, " Pdvdt = ", Pdvdt + if ( me == master ) write (56,*) "ahoj svete: in unified after & + &gwdps_run ", kdt, " Pdtdt = ", Pdtdt + if ( me == master ) write (58,*) "ahoj svete: in unified after & + &gwdps_run ", kdt, " hprime =", hprime + if ( me == master ) write (60,*) "ahoj svete: in unified after & + &gwdps_run ", kdt, " elvmax =", elvmax + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 @@ -430,6 +475,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (cdmbgwd(3) > 0.0) then + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_drag_run calling slat_geos5_tamp" + + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) @@ -468,6 +517,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_drag_run calling fv3_ugwp_solv2_v0" + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -487,6 +539,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else ! .not.(cdmbgwd(3) > 0.0) + ! Temporary line + if ( me == master ) print *, "ahoj svete: in unified_ugwp_run not calling slat_geos5_tamp" + do k=1,levs do i=1,im gw_dtdt(i,k) = Pdtdt(i,k) From bd921f53aadce0afe0a9744afc4042ff027accd1 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Fri, 18 Sep 2020 17:17:41 +0000 Subject: [PATCH 27/45] Bug fixes -- Sept. 18 --- physics/GFS_GWD_generic.F90 | 4 +++ physics/cires_ugwp.F90 | 33 ------------------------ physics/gwdps.f | 6 ----- physics/unified_ugwp.F90 | 50 ++----------------------------------- 4 files changed, 6 insertions(+), 87 deletions(-) diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 index ed3ff4484..2ab0fb37a 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic.F90 @@ -93,6 +93,10 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = mntvar(:,8) clx(:,3) = mntvar(:,9) clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) varss(:) = mntvar(:,15) ocss(:) = mntvar(:,16) oa4ss(:,1) = mntvar(:,17) diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 51f2b9504..df0116cd0 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -77,8 +77,6 @@ subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return if (do_ugwp .or. cdmbgwd(3) > 0.0) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_init calling cires_ugwp_mod_init" call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -226,9 +224,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr errmsg = '' errflg = 0 - ! Temporary line - if ( me == master ) write (41,*) "ahoj svete: qgrs(:,:,1) = ", qgrs(:,:,1) - ! 1) ORO stationary GWs ! ------------------ ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality @@ -246,9 +241,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr zlwb(:) = 0. - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling GWDPS_V0" - call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & @@ -258,9 +250,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr else ! calling old GFS gravity wave drag as is - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run possibly about to call gwdps_run" - do k=1,levs do i=1,im Pdvdt(i,k) = 0.0 @@ -271,8 +260,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling gwdps_run" call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & ugrs, vgrs, tgrs, qgrs, & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & @@ -284,17 +271,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (errflg/=0) return endif - if ( me == master ) write (51,*) "ahoj svete: in cires after & - &gwdps_run ", kdt, " Pdudt = ", Pdudt - if ( me == master ) write (53,*) "ahoj svete: in cires after & - &gwdps_run ", kdt, " Pdvdt = ", Pdvdt - if ( me == master ) write (55,*) "ahoj svete: in cires after & - &gwdps_run ", kdt, " Pdtdt = ", Pdtdt - if ( me == master ) write (57,*) "ahoj svete: in cires after & - &gwdps_run ", kdt, " hprime =", hprime - if ( me == master ) write (59,*) "ahoj svete: in cires after & - &gwdps_run ", kdt, " elvmax =", elvmax - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 @@ -316,9 +292,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (cdmbgwd(3) > 0.0) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling slat_geos5_tamp" - ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) @@ -357,9 +330,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo endif - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run calling fv3_ugwp_solv2_v0" - call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -379,9 +349,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr else - ! Temporary line - if ( me == master ) print *, "ahoj svete: in cires_ugwp_run, didn't call ngw schemes" - do k=1,levs do i=1,im gw_dtdt(i,k) = Pdtdt(i,k) diff --git a/physics/gwdps.f b/physics/gwdps.f index 63e9a7f7b..b09413f02 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -443,9 +443,6 @@ subroutine gwdps_run( & LCAP = KM LCAPP1 = LCAP + 1 ! -! Temporary line - if ( me == 0 ) print *, "ahoj svete: in gwdps_run, nmtvr =", nmtvr -! ! IF ( NMTVR == 14) then ! ---- for lm and gwd calculation points @@ -459,9 +456,6 @@ subroutine gwdps_run( & if (ipr == i) npr = npt ENDIF ENDDO - ! Temporary line - if (npt == 0 .and. me==0) print *, "ahoj svete: in gwdps_run ", - & kdt, " npt =", npt IF (npt == 0) RETURN ! No gwd/mb calculation done! ! ! if (lprnt) print *,' npt=',npt,' npr=',npr,' ipr=',ipr,' im=',im diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index f97e218d1..2c4c2a856 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -120,8 +120,6 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v0 ) then ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) if (cdmbgwd(3) > 0.0) then - ! Temporary line - if ( me==master ) print *, "ahoj svete: in unified_ugwp_init calling cires_ugwp_mod_init" call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -135,8 +133,6 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v1 ) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_init calling cires_ugwp_init_v1" call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -335,25 +331,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, zlwb(:) = 0. - ! Temporary lines - if ( me == master ) write (80,*) "ahoj svete: in unified beginning ", & - kdt, " elvmax =", elvmax - if ( me == master ) write (81,*) "ahoj svete: in unified beginning ", & - kdt, " sigma =", sigma - if ( me == master ) write (82,*) "ahoj svete: in unified beginning ", & - kdt, " oc =", oc - - - ! Temporary line - if ( me == master ) write (40,*) "ahoj svete: q1 = ", q1 - ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd ) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling drag_suite_run" call drag_suite_run(im,levs,dvdt,dudt,dtdt,ugrs,vgrs,tgrs,q1, & kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & @@ -370,9 +352,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling gwdps_oro_v1" - ! Valery's TOFD ! topo paras ! w/ orographic effects @@ -400,9 +379,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_run getting ready to call something" - do k=1,levs do i=1,im Pdvdt(i,k) = 0.0 @@ -413,15 +389,14 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_run calling gwdps_run" ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary if ( nmtvr == 24 ) then ! gwd_opt = 2, 22, 3, or 33 nmtvr_temp = 14 else - nmtvr_temp = nmtvr + nmtvr_temp = nmtvr end if + call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & ugrs, vgrs, tgrs, q1, & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & @@ -433,17 +408,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (errflg/=0) return endif - if ( me == master ) write (52,*) "ahoj svete: in unified after & - &gwdps_run ", kdt, " Pdudt = ", Pdudt - if ( me == master ) write (54,*) "ahoj svete: in unified after & - &gwdps_run ", kdt, " Pdvdt = ", Pdvdt - if ( me == master ) write (56,*) "ahoj svete: in unified after & - &gwdps_run ", kdt, " Pdtdt = ", Pdtdt - if ( me == master ) write (58,*) "ahoj svete: in unified after & - &gwdps_run ", kdt, " hprime =", hprime - if ( me == master ) write (60,*) "ahoj svete: in unified after & - &gwdps_run ", kdt, " elvmax =", elvmax - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 @@ -475,10 +439,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (cdmbgwd(3) > 0.0) then - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_drag_run calling slat_geos5_tamp" - - ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) @@ -517,9 +477,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_drag_run calling fv3_ugwp_solv2_v0" - call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -539,9 +496,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, else ! .not.(cdmbgwd(3) > 0.0) - ! Temporary line - if ( me == master ) print *, "ahoj svete: in unified_ugwp_run not calling slat_geos5_tamp" - do k=1,levs do i=1,im gw_dtdt(i,k) = Pdtdt(i,k) From 44e298aa7c3b0275c71450588fad0837a1b7f895 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 24 Sep 2020 16:29:40 +0000 Subject: [PATCH 28/45] Removed if(.not. restart) around the call to rucinit. --- physics/sfc_drv_ruc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 5370cd763..d54561d21 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -125,7 +125,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & endif enddo - if( .not. flag_restart) then + !if( .not. flag_restart) then call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in soiltyp, vegtype, & ! in @@ -142,7 +142,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & enddo enddo ! i - endif ! flag_restart + !endif ! flag_restart !-- end of initialization if ( debug_print) then From a96775edd755b13ed28f2d9f700eb3283372bb24 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 29 Sep 2020 14:37:18 +0000 Subject: [PATCH 29/45] Sept. 28 bug fix --- physics/unified_ugwp.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 2c4c2a856..bdd0fbb70 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -350,7 +350,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) - else if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then + end if + + if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then ! Valery's TOFD ! topo paras @@ -377,7 +379,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & du3dt_mtb, du3dt_ogw, du3dt_tms) - else if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then do k=1,levs do i=1,im From 52c4f54ef093836d73c664780274deb999b402e2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 1 Oct 2020 15:41:39 -0600 Subject: [PATCH 30/45] Remove switch between WRFv3.8.1 and v4+ in module_mp_thompson.F90 --- physics/module_mp_thompson.F90 | 65 +++------------------------------- 1 file changed, 4 insertions(+), 61 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 304afc6d5..14604e625 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1,12 +1,6 @@ !>\file module_mp_thompson.F90 !! This file contains the entity of GSD Thompson MP scheme. -! DH* 2020-06-05 -! Use the following preprocessor directive to roll back -! to the WRFv3.8.1, used in RAPv5/HRRRv4 for more reasonable -! representation of mesoscale storms and reflectivity values -!#define WRF381 - !>\ingroup aathompson !! This module computes the moisture tendencies of water vapor, @@ -463,13 +457,6 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & if (.NOT. ALLOCATED(tcg_racg) ) then ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) micro_init = .TRUE. - if (mpirank==mpiroot) then -#ifdef WRF381 - write(0,*) "Using Thompson MP from WRFv3.8.1 (RAPv5/HRRRv4)" -#else - write(0,*) "Using Thompson MP from WRFv4.0+" -#endif - endif endif if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) @@ -2715,13 +2702,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! supersat again. sump = pri_inu(k) + pri_ide(k) + prs_ide(k) & + prs_sde(k) + prg_gde(k) + pri_iha(k) -! DH* 2020-06-02 I believe that the WRF381 version -! is wrong, because the units do not match. -#ifdef WRF381 - rate_max = (qv(k)-qvsi(k))*odts*0.999 -#else rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 -#endif if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then ratio = rate_max/sump @@ -3598,7 +3579,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo -#ifdef WRF381 +#if 1 if (rr(kts).gt.R1*10.) & #else if (rr(kts).gt.R1*1000.) & @@ -3653,7 +3634,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo -#ifdef WRF381 +#if 1 if (ri(kts).gt.R1*10.) & #else if (ri(kts).gt.R1*1000.) & @@ -3684,7 +3665,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo -#ifdef WRF381 +#if 1 if (rs(kts).gt.R1*10.) & #else if (rs(kts).gt.R1*1000.) & @@ -3715,7 +3696,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo -#ifdef WRF381 +#if 1 if (rg(kts).gt.R1*10.) & #else if (rg(kts).gt.R1*1000.) & @@ -3760,21 +3741,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) -! DH* 2020-06-05 I believe WRF381 is wrong in terms of units; -! dividing by rho turns number concentration per volume into -! number concentration per mass. -#ifdef WRF381 nwfa1d(k) = MAX(11.1E6/rho(k), MIN(9999.E6/rho(k), & (nwfa1d(k)+nwfaten(k)*DT))) nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6/rho(k), & (nifa1d(k)+nifaten(k)*DT))) -#else - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & - (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & - (nifa1d(k)+nifaten(k)*DT))) -#endif - if (qc1d(k) .le. R1) then qc1d(k) = 0.0 nc1d(k) = 0.0 @@ -5275,31 +5245,14 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & ! are consistent with the WRFv3.8.1 settings, but inconsistent ! with the WRFv4+ settings. In order to apply the same bounds ! as before this change, use the WRF v3.8.1 settings throughout. -#if 1 -!ifdef WRF381 re_qc1d(:) = 2.49E-6 re_qi1d(:) = 4.99E-6 re_qs1d(:) = 9.99E-6 -#else - re_qc1d(:) = 2.49E-6 - re_qi1d(:) = 2.49E-6 - re_qs1d(:) = 4.99E-6 -#endif do k = kts, kte rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) rc(k) = MAX(R1, qc1d(k)*rho(k)) -#ifdef WRF381 - nc(k) = MAX(R2, MIN(nc1d(k)*rho(k), Nt_c_max)) -#else - ! DH* 2020-06-05 is using 2.0 instead of R2 - ! a bug in the WRFv4.0+ version of Thompson? - ! For ni(k) a few lines below, it is still R2. - ! Note that R2 is defined as R2 = 1.E-6, and is - ! used in other parts of Thompson MP for ni/nr - ! calculations (but not for nc calculations) nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) -#endif if (.NOT. is_aerosol_aware) nc(k) = Nt_c if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. ri(k) = MAX(R1, qi1d(k)*rho(k)) @@ -5328,12 +5281,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi -#if 1 -!ifdef WRF381 re_qi1d(k) = MAX(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#else - re_qi1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#endif enddo endif @@ -5373,12 +5321,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) smoc = a_ * smo2**b_ -#if 1 -!ifdef WRF381 re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) -#else - re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) -#endif enddo endif From a2728b5ee1ae08519a76155aa39f5d66aede55fc Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 6 Oct 2020 01:59:28 +0000 Subject: [PATCH 31/45] updating tasks 1 --- physics/unified_ugwp.meta | 6 ++++++ physics/unified_ugwp_post.meta | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 23610f99c..038384044 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = unified_ugwp + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = unified_ugwp_init type = scheme diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index 807584e94..501e91b8f 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = unified_ugwp_post + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = unified_ugwp_post_init type = scheme From 06b7a076c76d777bce22ba80f817e756041b4a1d Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 7 Oct 2020 15:08:28 +0000 Subject: [PATCH 32/45] Updated unified_ugwp.meta to include dependencies. --- physics/unified_ugwp.meta | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 038384044..80a4f56d6 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - dependencies = machine.F + dependencies = machine.F,cires_ugwp_module.F90,cires_ugwp_module_v1.F90,gwdps.f,drag_suite.F90 + dependencies = cires_ugwp_orolm97_v1.F90,cires_ugwp_triggers_v1.F90,cires_ugwp_solv2_v1_mod.F90 + dependencies = cires_ugwp_module.F90,cires_ugwp_module_v1.F90,cires_ugwp_initialize_v1.F90 + dependencies = cires_ugwp_initialize.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 ######################################################################## [ccpp-arg-table] From 94aa9b1ce6b11e01ff526db070c5493ddc71ec4f Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 7 Oct 2020 18:00:55 +0000 Subject: [PATCH 33/45] Finalized unified_ugwp.meta dependencies --- physics/unified_ugwp.meta | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 80a4f56d6..96eb8b97e 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -3,8 +3,9 @@ type = scheme dependencies = machine.F,cires_ugwp_module.F90,cires_ugwp_module_v1.F90,gwdps.f,drag_suite.F90 dependencies = cires_ugwp_orolm97_v1.F90,cires_ugwp_triggers_v1.F90,cires_ugwp_solv2_v1_mod.F90 - dependencies = cires_ugwp_module.F90,cires_ugwp_module_v1.F90,cires_ugwp_initialize_v1.F90 - dependencies = cires_ugwp_initialize.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 + dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_initialize.F90 + dependencies = cires_orowam2017.F90,cires_vert_orodis_v1.F90,cires_ugwp_utils.F90 + dependencies = cires_ugwp_triggers.F90,cires_ugwp_solvers.F90 ######################################################################## [ccpp-arg-table] From d6cd89caf61195be12d480ef0c1b6c03ea48cadc Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 8 Oct 2020 03:20:40 +0000 Subject: [PATCH 34/45] Another unified_ugwp.meta bugfix --- physics/unified_ugwp.meta | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 96eb8b97e..28aa196d3 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,11 +1,13 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - dependencies = machine.F,cires_ugwp_module.F90,cires_ugwp_module_v1.F90,gwdps.f,drag_suite.F90 - dependencies = cires_ugwp_orolm97_v1.F90,cires_ugwp_triggers_v1.F90,cires_ugwp_solv2_v1_mod.F90 - dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_initialize.F90 - dependencies = cires_orowam2017.F90,cires_vert_orodis_v1.F90,cires_ugwp_utils.F90 - dependencies = cires_ugwp_triggers.F90,cires_ugwp_solvers.F90 + dependencies = machine.F,cires_ugwp_module.F90,ugwp_driver_v0.F,cires_ugwp_triggers.F90 + dependencies = cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90 + dependencies = cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90 + dependencies = cires_vert_wmsdis.F90,cires_ugwp_module_v1.F90,cires_ugwp_triggers_v1.F90 + dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_solv2_v1_mod.F90 + dependencies = cires_ugwp_orolm97_v1.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 + dependencies = gwdps.f,drag_suite.F90 ######################################################################## [ccpp-arg-table] From b018da0982bd92bc2880eda43c861566e6631957 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 13 Oct 2020 15:27:51 +0000 Subject: [PATCH 35/45] Updated unified_ugwp documentation. --- physics/docs/library.bib | 41 +++++++++++++++++++++++++++++++++++ physics/unified_ugwp.F90 | 27 +++++++++++++++++++++-- physics/unified_ugwp_post.F90 | 4 ++-- 3 files changed, 68 insertions(+), 4 deletions(-) diff --git a/physics/docs/library.bib b/physics/docs/library.bib index dd2b2042e..b96226e04 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3197,3 +3197,44 @@ @inproceedings{yudin_et_al_2019 Booktitle = {Space Weather Workshop}, Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, Year = {2019}} + +@article{kim_and_doyle_2005, + Author = {Y.-J. Kim and J.D. Arakawa}, + Doi = {10.1256/qj.04.160}, + Url = {https://doi.org/10.1256/qj.04.160}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1893-1921}, + Title = {Extension of an orographic-drag parametrization scheme to incorporate orographic inisotropy and flow blocking}, + Volume = {131}, + Year = {2005}} + +@article{steeneveld_et_al_2008, + Author = {Steeneveld, G. J.,A.A. M. Holtslag, C. J. Nappo, B. J. H. van de Wiel, and L. Mahrt}, + Doi = {10.1175/2008JAMC1816.1}, + Url = {https://doi.org/10.1175/2008JAMC1816.1}, + Journal = {J. Appl. Meteor.}, + Pages = {2518-2530}, + Title = {Exploring the possible role of small-scale terrain drag on stable boundary layers over land}, + Volume = {47}, + Year = {2008}} + +@article{tsiringakis_et_al_2017, + Author = {Tsiringakis,A., G. J. Steeneveld, and A.A. M. Holtslag}, + Doi = {10.1002/qj.3021}, + Url = {https://doi.org/10.1002/qj.3021}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1504-1516}, + Title = {Small-scale orographic gravity wave drag in stable boundary layers and its impact on synoptic systems and near-surface meteorology}, + Volume = {143}, + Year = {2017}} + +@article{beljaars_et_al_2004, + Author = {Beljaars, A.C.M., A.R.Brown, and N.Wood}, + Doi = {10.1256/qj.03.73}, + Url = {https://doi.org/10.1256/qj.03.73}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1327-1347}, + Title = {A new parametrization of turbulent orographic form drag}, + Volume = {130}, + Year = {2004}} + diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index bdd0fbb70..13b9f9193 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -1,5 +1,16 @@ !> \file unified_ugwp.F90 -!! This file contains the Unified Gravity Wave Physics (UGWP) scheme by Valery Yudin (University of Colorado, CIRES) +!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: +!! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f +!! b) the v0 cires ugwp non-stationary GWD scheme +!! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: +!! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales +!! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) +!! b) small-scale gravity wave drag scheme -- active typically in stable PBL at horizontal grid resolutions down to ~1km +!! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) +!! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km +!! (Beljaars et al, 2004 \cite beljaars_et_al_2004) +!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) !! See Valery Yudin's presentation at 2017 NGGPS PI meeting: !! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers !! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics @@ -9,6 +20,18 @@ !! 2. GW Propagation: Unified solver for "propagation, dissipation and breaking" excited from all type of GW sources. !! 3. GW Effects: Unified representation of GW impacts on the "resolved" flow for all sources (energy-balanced schemes for momentum, heat and mixing). !! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf +!! +!! The unified_ugwp scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD +!! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag +!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only +!! Note that only one "large-scale" scheme can be activated at a time. +!! module unified_ugwp @@ -43,7 +66,7 @@ module unified_ugwp ! ------------------------------------------------------------------------ ! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 ! ------------------------------------------------------------------------ -!>@brief The subroutine initializes the CIRES UGWP +!>@brief The subroutine initializes the unified UGWP !> \section arg_table_unified_ugwp_init Argument Table !! \htmlinclude unified_ugwp_init.html !! diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 index ac11b4eb1..5e43f2830 100644 --- a/physics/unified_ugwp_post.F90 +++ b/physics/unified_ugwp_post.F90 @@ -4,14 +4,14 @@ module unified_ugwp_post contains -!>\defgroup unified_ugwp_post CIRES UGWP Scheme Post +!>\defgroup unified_ugwp_post unified_UGWP Scheme Post !! @{ !> \section arg_table_unified_ugwp_post_init Argument Table !! subroutine unified_ugwp_post_init () end subroutine unified_ugwp_post_init -!>@brief The subroutine initializes the CIRES UGWP +!>@brief The subroutine initializes the unified UGWP #if 0 !> \section arg_table_unified_ugwp_post_run Argument Table !! \htmlinclude unified_ugwp_post_run.html From 2b4141930ce13c2f8e5e750c9bbe5da622f45a3e Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 13 Oct 2020 19:30:43 +0000 Subject: [PATCH 36/45] If restart=.true. do not set XLAI=0 in the initialization. --- physics/sfc_drv_ruc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index d54561d21..a8f975aa2 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -419,7 +419,7 @@ subroutine lsm_ruc_run & ! inputs if(flag_init .and. iter==1) then ! Initialize the RUC soil levels, needed for cold starts and warm starts CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - xlai = 0. + if (.not. restart) !xlai = 0. endif ! flag_init=.true.,iter=1 ims = 1 From 762beebb2337d94ba455837a1467b8f5f1857ba3 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 13 Oct 2020 19:35:08 +0000 Subject: [PATCH 37/45] Corrected syntax error. --- physics/sfc_drv_ruc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index a8f975aa2..6626d8fb6 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -419,7 +419,7 @@ subroutine lsm_ruc_run & ! inputs if(flag_init .and. iter==1) then ! Initialize the RUC soil levels, needed for cold starts and warm starts CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - if (.not. restart) !xlai = 0. + if (.not. restart) xlai = 0. endif ! flag_init=.true.,iter=1 ims = 1 From 7d6d8ce473297eed5224cd3a52a1ddffbbe41b9b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 14 Oct 2020 09:15:53 -0600 Subject: [PATCH 38/45] Add capability to print debugging output for all blocks and threads in init phase --- physics/GFS_debug.F90 | 63 +++++++++++++++++++++++++++-- physics/GFS_debug.meta | 92 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+), 3 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 35b44ca0e..4680f8de7 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -311,7 +311,37 @@ module GFS_diagtoscreen contains - subroutine GFS_diagtoscreen_init () +!> \section arg_table_GFS_diagtoscreen_init Argument Table +!! \htmlinclude GFS_diagtoscreen_init.html +!! + subroutine GFS_diagtoscreen_init (Model, Data, Interstitial, errmsg, errflg) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type, & + GFS_interstitial_type + + implicit none + + !--- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_data_type), intent(in) :: Data(:) + type(GFS_interstitial_type), intent(in) :: Interstitial(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,size(Data) + call GFS_diagtoscreen_run (Model, Data(i)%Statein, Data(i)%Stateout, Data(i)%Sfcprop, & + Data(i)%Coupling, Data(i)%Grid, Data(i)%Tbd, Data(i)%Cldprop, & + Data(i)%Radtend, Data(i)%Intdiag, Interstitial(1), & + size(Interstitial), i, errmsg, errflg) + end do + end subroutine GFS_diagtoscreen_init subroutine GFS_diagtoscreen_finalize () @@ -330,7 +360,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #ifdef OPENMP use omp_lib #endif - use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_statein_type, & GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & @@ -831,7 +860,35 @@ module GFS_interstitialtoscreen contains - subroutine GFS_interstitialtoscreen_init () + subroutine GFS_interstitialtoscreen_init (Model, Data, Interstitial, errmsg, errflg) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type, & + GFS_interstitial_type + + implicit none + + !--- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_data_type), intent(in) :: Data(:) + type(GFS_interstitial_type), intent(in) :: Interstitial(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + do i=1,size(Interstitial) + call GFS_interstitialtoscreen_run (Model, Data(1)%Statein, Data(1)%Stateout, Data(1)%Sfcprop, & + Data(1)%Coupling, Data(1)%Grid, Data(1)%Tbd, Data(1)%Cldprop, & + Data(1)%Radtend, Data(1)%Intdiag, Interstitial(i), & + size(Interstitial), -999, errmsg, errflg) + end do + end subroutine GFS_interstitialtoscreen_init subroutine GFS_interstitialtoscreen_finalize () diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index d93e22328..6e6315d5b 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -3,6 +3,52 @@ type = scheme dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = GFS_diagtoscreen_init + type = scheme +[Model] + standard_name = GFS_control_type_instance + long_name = instance of derived type GFS_control_type in FV3 + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[Data] + standard_name = GFS_data_type_instance_all_blocks + long_name = instance of derived type GFS_data_type + units = DDT + dimensions = (ccpp_block_count) + type = GFS_data_type + intent = in + optional = F +[Interstitial] + standard_name = GFS_interstitial_type_instance_all_threads + long_name = instance of derived type GFS_interstitial_type + units = DDT + dimensions = (omp_threads) + type = GFS_interstitial_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_diagtoscreen_run @@ -135,6 +181,52 @@ type = scheme dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = GFS_interstitialtoscreen_init + type = scheme +[Model] + standard_name = GFS_control_type_instance + long_name = instance of derived type GFS_control_type in FV3 + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[Data] + standard_name = GFS_data_type_instance_all_blocks + long_name = instance of derived type GFS_data_type + units = DDT + dimensions = (ccpp_block_count) + type = GFS_data_type + intent = in + optional = F +[Interstitial] + standard_name = GFS_interstitial_type_instance_all_threads + long_name = instance of derived type GFS_interstitial_type + units = DDT + dimensions = (omp_threads) + type = GFS_interstitial_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_interstitialtoscreen_run From 05b9aba6cad4760c5f5fdd9e55e8485a88c28674 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 14 Oct 2020 09:19:17 -0600 Subject: [PATCH 39/45] Fix RUC LSM initialization --- physics/sfc_drv_ruc.F90 | 123 +++++++++++++++++---------------------- physics/sfc_drv_ruc.meta | 21 +++++-- 2 files changed, 68 insertions(+), 76 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 6626d8fb6..7af8c3497 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -31,7 +31,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & lsm_ruc, lsm, slmsk, stype, vtype, & ! in tsfc_lnd, tsfc_wat, & ! in tg3, smc, slc, stc, & ! in - sh2o, smfrkeep, tslb, smois, wetness, & ! out + zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out tsice, errmsg, errflg) implicit none @@ -47,12 +47,12 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & integer, intent(in) :: lsm_ruc, lsm - real (kind=kind_phys), dimension(im), intent(in ) :: slmsk - real (kind=kind_phys), dimension(im), intent(in ) :: stype - real (kind=kind_phys), dimension(im), intent(in ) :: vtype - real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_lnd - real (kind=kind_phys), dimension(im), intent(in ) :: tsfc_wat - real (kind=kind_phys), dimension(im), intent(in) :: tg3 + real (kind=kind_phys), dimension(im), intent(in) :: slmsk + real (kind=kind_phys), dimension(im), intent(in) :: stype + real (kind=kind_phys), dimension(im), intent(in) :: vtype + real (kind=kind_phys), dimension(im), intent(in) :: tsfc_lnd + real (kind=kind_phys), dimension(im), intent(in) :: tsfc_wat + real (kind=kind_phys), dimension(im), intent(in) :: tg3 real (kind=kind_phys), dimension(im,lsoil), intent(in) :: smc,slc,stc @@ -60,14 +60,16 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(im), intent(inout) :: wetness ! --- out - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(out) :: sh2o, smfrkeep - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(out) :: tslb, smois + real (kind=kind_phys), dimension(:), intent(out) :: zs + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o, smfrkeep + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb, smois real (kind=kind_phys), dimension(im,kice), intent(out) :: tsice character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- local + real (kind=kind_phys), dimension(lsoil_ruc) :: dzs integer :: ipr, i, k logical :: debug_print integer, dimension(im) :: soiltyp, vegtype @@ -125,14 +127,16 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & endif enddo + call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) + !if( .not. flag_restart) then call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tsfc_lnd, tsfc_wat, tg3, & ! in - smc, slc, stc, & ! in - sh2o, smfrkeep, tslb, smois, & ! out - wetness, errmsg, errflg) + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) @@ -146,10 +150,10 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !-- end of initialization if ( debug_print) then - write (0,*) 'ruc soil tslb',tslb(:,1) - write (0,*) 'ruc soil tsice',tsice(:,1) - write (0,*) 'ruc soil smois',smois(:,1) - write (0,*) 'ruc wetness',wetness(:) + write (0,*) 'ruc soil tslb',tslb(ipr,:) + write (0,*) 'ruc soil tsice',tsice(ipr,:) + write (0,*) 'ruc soil smois',smois(ipr,:) + write (0,*) 'ruc wetness',wetness(ipr) endif end subroutine lsm_ruc_init @@ -303,8 +307,7 @@ subroutine lsm_ruc_run & ! inputs ! --- in/out: integer, dimension(im), intent(inout) :: soiltyp, vegtype - real (kind=kind_phys), dimension(lsoil_ruc) :: dzs - real (kind=kind_phys), dimension(lsoil_ruc), intent(inout ) :: zs + real (kind=kind_phys), dimension(lsoil_ruc), intent(in) :: zs real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & & snwdph, tskin, tskin_wat, & & srflag, canopy, trans, tsurf, zorl, tsnow, & @@ -415,12 +418,6 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'flag_init =',flag_init write (0,*)'flag_restart =',flag_restart endif - - if(flag_init .and. iter==1) then - ! Initialize the RUC soil levels, needed for cold starts and warm starts - CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - if (.not. restart) xlai = 0. - endif ! flag_init=.true.,iter=1 ims = 1 its = 1 @@ -705,7 +702,11 @@ subroutine lsm_ruc_run & ! inputs albbck(i,j) = max(0.01, 0.5 * (alvwf(i) + alnwf(i))) alb(i,j) = sfalb(i) - if(rdlai2d) xlai(i,j) = laixy(i) + if(rdlai2d) then + xlai(i,j) = laixy(i) + else + xlai(i,j) = 0. + endif tbot(i,j) = tg3(i) @@ -1082,30 +1083,14 @@ subroutine lsm_ruc_run & ! inputs deallocate(landusef) ! !! Update standard (Noah LSM) soil variables for physics - !! that require these variables (e.g. sfc_sice), independent - !! of whether it is a land point or not - !do i = 1, im - ! if (land(i)) then - ! do k = 1, lsoil - ! smc(i,k) = smois(i,k) - ! slc(i,k) = sh2o(i,k) - ! stc(i,k) = tslb(i,k) - ! enddo - ! endif - !enddo - ! - !write(0,*) "DH DEBUG: i, k, land(i), smc(i,k), slc(i,k), stc(i,k):" - !do i = 1, im - ! do k = 1, lsoil - ! write(0,'(2i5,1x,l,1x,3e20.10)'), i, k, land(i), smc(i,k), slc(i,k), stc(i,k) - ! smc(i,k) = smois(i,k) - ! slc(i,k) = sh2o(i,k) - ! stc(i,k) = tslb(i,k) - ! enddo - !enddo - - !call sleep(20) - !stop + !! that require these variables and for debugging purposes + do i = 1, im + do k = 1, lsoil + smc(i,k) = smois(i,k) + slc(i,k) = sh2o(i,k) + stc(i,k) = tslb(i,k) + enddo + enddo return !................................... @@ -1118,24 +1103,26 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in soiltyp, vegtype, & ! in tskin_lnd, tskin_wat, tg3, & ! !in - smc, slc, stc, & ! in + zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) implicit none - logical, intent(in ) :: restart - integer, intent(in ) :: lsm - integer, intent(in ) :: lsm_ruc - integer, intent(in ) :: im, nlev - integer, intent(in ) :: lsoil_ruc - integer, intent(in ) :: lsoil - real (kind=kind_phys), dimension(im), intent(in ) :: slmsk - real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat - real (kind=kind_phys), dimension(im), intent(in ) :: tg3 - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah + logical, intent(in ) :: restart + integer, intent(in ) :: lsm + integer, intent(in ) :: lsm_ruc + integer, intent(in ) :: im, nlev + integer, intent(in ) :: lsoil_ruc + integer, intent(in ) :: lsoil + real (kind=kind_phys), dimension(im), intent(in ) :: slmsk + real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat + real (kind=kind_phys), dimension(im), intent(in ) :: tg3 + real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs + real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah integer, dimension(im), intent(inout) :: soiltyp integer, dimension(im), intent(inout) :: vegtype @@ -1157,7 +1144,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer :: flag_soil_layers, flag_soil_levels, flag_sst real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm - real (kind=kind_phys), dimension(1:lsoil_ruc) :: zs real (kind=kind_phys), dimension(im) :: smcref2 real (kind=kind_phys), dimension(im) :: smcwlt2 @@ -1185,7 +1171,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in its,ite, jts,jte, kts,kte, & i, j, k, l, num_soil_layers, ipr - real(kind=kind_phys), dimension(1:lsoil_ruc) :: zs2, dzs integer, dimension(1:lsoil) :: st_levels_input ! 4 - for Noah lsm integer, dimension(1:lsoil) :: sm_levels_input ! 4 - for Noah lsm @@ -1205,6 +1190,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in else if (debug_print) then write (0,*) 'Start of RUC LSM initialization' write (0,*)'lsoil, lsoil_ruc =',lsoil, lsoil_ruc + write (0,*)'restart = ',restart endif ipr = 10 @@ -1229,9 +1215,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in kme = nlev kte = nlev - ! Initialize the RUC soil levels, needed for cold starts and warm starts - CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - !! Check if RUC soil data (tslb, ...) is provided or not !if (minval(tslb)==maxval(tslb)) then ! For restart runs, can assume that RUC soul data is provided diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 509c22588..8737f0d60 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -200,6 +200,15 @@ kind = kind_phys intent = in optional = F +[zs] + standard_name = depth_of_soil_levels_for_land_surface_model + long_name = depth of soil levels for land surface model + units = m + dimensions = (soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F [sh2o] standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model long_name = volume fraction of unfrozen soil moisture for lsm @@ -207,7 +216,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = out + intent = inout optional = F [smfrkeep] standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model @@ -216,7 +225,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = out + intent = inout optional = F [tslb] standard_name = soil_temperature_for_land_surface_model @@ -225,7 +234,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = out + intent = inout optional = F [smois] standard_name = volume_fraction_of_soil_moisture_for_land_surface_model @@ -234,7 +243,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = out + intent = inout optional = F [wetness] standard_name = normalized_soil_wetness_for_land_surface_model @@ -243,7 +252,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [tsice] standard_name = internal_ice_temperature @@ -369,7 +378,7 @@ dimensions = (soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = inout + intent = in optional = F [t1] standard_name = air_temperature_at_lowest_model_layer From 748b0bc508af21d175aebc997179c497894a97ca Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 22 Oct 2020 02:43:04 +0000 Subject: [PATCH 40/45] Modified code per PR recommendations --- physics/cires_orowam2017.F90 | 17 +++++--- physics/cires_ugwp_initialize_v1.F90 | 34 +++++++++------ physics/cires_ugwp_module_v1.F90 | 65 +++++++++++++++------------- physics/cires_ugwp_orolm97_v1.F90 | 30 ++++++++++--- physics/cires_ugwp_solv2_v1_mod.F90 | 43 +++++++++++++----- physics/cires_ugwp_triggers_v1.F90 | 30 ++++++++----- physics/cires_vert_orodis_v1.F90 | 31 ++++++++----- physics/ugwp_driver_v0.F | 10 ++++- physics/unified_ugwp.F90 | 39 +++++++++-------- physics/unified_ugwp.meta | 36 +++++++++++++++ physics/unified_ugwp_post.F90 | 4 +- 11 files changed, 231 insertions(+), 108 deletions(-) diff --git a/physics/cires_orowam2017.F90 b/physics/cires_orowam2017.F90 index d5568bb9d..d5fda5cc0 100644 --- a/physics/cires_orowam2017.F90 +++ b/physics/cires_orowam2017.F90 @@ -6,11 +6,10 @@ module cires_orowam2017 subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & - & del, sigma, hprime, gamma, theta, & + & grav, omega, con_rd, del, sigma, hprime, gamma, theta, & & sinlat, xlatd, taup, taud, pkdis) ! USE MACHINE , ONLY : kind_phys - use ugwp_common_v1 , only : grav, omega2 ! implicit none @@ -29,6 +28,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & real(kind=kind_phys), intent(in), dimension(im, levs) :: & & u1, v1, t1, bn2, rho, prsl, del + real(kind=kind_phys), intent(in) :: grav, omega, con_rd real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi ! @@ -128,11 +128,12 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & wkdis(:,:) = kedmin call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & - & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), & + & prsi(j,:), prsL(j,:), grav, con_rd, & + & del(j,:), rho(i,:), & & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & & xn(i), yn(i)) - fcor2 = (omega2*sinlat(j))*(omega2*sinlat(j))*fc_flag + fcor2 = (2*omega*sinlat(j))*(2*omega*sinlat(j))*fc_flag k = ksrc @@ -282,9 +283,10 @@ end subroutine oro_wam_2017 ! !------------------------------------------------------------- subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & grav, con_rd, & & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) - use ugwp_common_v1 , only : grav, rgrav, rdi, velmin, dw2min + use ugwp_common_v1 , only : velmin, dw2min implicit none integer :: nz, nzi @@ -292,6 +294,7 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & real, dimension(nz ) :: bn2 ! define at the interfaces real, dimension(nz+1) :: pint real :: xn, yn + real,intent(in) :: grav, con_rd ! output real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp @@ -300,6 +303,7 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & integer :: i, j, k real :: ui, vi, ti, uz, vz, shr2, rdz, kamp real :: zgrow, zmet, rdpm, ritur, kmol, w1 + real :: rgrav, rdi ! paremeters real, parameter :: hps = 7000., rpspa = 1.e-5 real, parameter :: rhps=1.0/hps @@ -309,6 +313,9 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb kalp(1:nzi) = 2.e-7 ! radiative damping + rgrav = 1.0/grav + rdi = 1.0/con_rd + do k=2, nz rdpm = grav/(pmid(k-1)-pmid(k)) ui = .5*(u1(k-1)+u1(k)) diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 index ef6c2c7d1..4258680ea 100644 --- a/physics/cires_ugwp_initialize_v1.F90 +++ b/physics/cires_ugwp_initialize_v1.F90 @@ -54,15 +54,14 @@ end module ugwp_common_v1 !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + pa_rf, tau_rf, me, master) - use ugwp_common_v1, only : pih - implicit none integer , intent(in) :: me, master integer , intent(in) :: levs - real, intent(in) :: pa_rf, tau_rf + real, intent(in) :: con_pi, pa_rf, tau_rf real, intent(in) :: zkm(levs), pmb(levs) ! in km-Pa real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion ! @@ -91,6 +90,10 @@ subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau real :: rf_fv3, rtau_fv3, ptop, pih_dlog ! real :: ae1 ,ae2 + real :: pih + + pih = 0.5*con_pi + pa_alp = pa_rf tau_alp = tau_rf @@ -335,12 +338,13 @@ module ugwp_conv_init_v1 contains ! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cgwf) - use ugwp_common_v1, only : pi2, arad + con_pi, arad, lonr, kxw, cgwf) + implicit none integer :: nwaves, nazdir, nstoch integer :: lonr + real :: con_pi, arad real :: cgwf(2) real :: kxw, effac real :: work1 = 0.5 @@ -352,7 +356,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & nstcon = nstoch eff_con = effac - con_dlength = pi2*arad/float(lonr) + con_dlength = 2.0*con_pi*arad/float(lonr) con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) ! ! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" @@ -378,7 +382,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & snorm = sum(spf_conv) spf_conv = spf_conv/snorm*1.5 - call init_nazdir(nazdir, xaz_conv, yaz_conv) + call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) end subroutine init_conv_gws @@ -405,12 +409,13 @@ module ugwp_fjet_init_v1 real, allocatable :: ch_fjet(:) , spf_fjet(:) real, allocatable :: xaz_fjet(:), yaz_fjet(:) contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common_v1, only : pi2, arad + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) implicit none integer :: nwaves, nazdir, nstoch integer :: lonr + real :: con_pi real :: kxw, effac , chk integer :: k @@ -431,7 +436,7 @@ subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) ch_fjet(k) = chk spf_fjet(k) = 1.0 enddo - call init_nazdir(nazdir, xaz_fjet, yaz_fjet) + call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) end subroutine init_fjet_gws @@ -459,13 +464,14 @@ module ugwp_okw_init_v1 contains ! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) - use ugwp_common_v1, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch integer :: lonr + real :: con_pi real :: kxw, effac , chk integer :: k @@ -486,7 +492,7 @@ subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) spf_okwp(k) = 1. enddo - call init_nazdir(nazdir, xaz_okwp, yaz_okwp) + call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) end subroutine init_okw_gws diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 index a25854097..9b245ed11 100644 --- a/physics/cires_ugwp_module_v1.F90 +++ b/physics/cires_ugwp_module_v1.F90 @@ -39,12 +39,12 @@ module cires_ugwp_module_v1 ! integer :: curday_ugwp ! yyyymmdd 20150101 ! integer :: ddd_ugwp ! ddd of year from 1-366 - integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) - integer, dimension(4) :: knob_ugwp_source ! [1,1,1,0] - (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_wvspec ! number of waves for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_azdir ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_stoch ! 1 - deterministic ; 0 - stochastic - real, dimension(4) :: knob_ugwp_effac ! efficiency factors for- (oro, fronts, conv, imbf-owp] + integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) + integer, dimension(4) :: knob_ugwp_source=(/1,0,1,0/) ! [1,0,1,1] - (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_wvspec=(/1,32,32,32/) ! number of waves for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_azdir=(/2,4,4,4/) ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_stoch=(/0,0,0,0/) ! 0 - deterministic ; 1 - stochastic + real, dimension(4) :: knob_ugwp_effac=(/1.,1.,1.,1./) ! efficiency factors for- (oro, fronts, conv, imbf-owp] integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag integer :: knob_ugwp_doheat=1 ! 1 -gwheat @@ -94,11 +94,6 @@ module cires_ugwp_module_v1 real :: ugwp_effac ! - data knob_ugwp_source / 1,0, 1, 0 / ! oro-conv-fjet-okw-taub_lat: 1-active 0-off - data knob_ugwp_wvspec /1,32,32,32/ ! number of waves for- (oro, fronts, conv, imbf-owp, taulat] - data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] - data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option - data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] integer :: knob_ugwp_version = 0 integer :: launch_level = 55 ! @@ -170,9 +165,9 @@ module cires_ugwp_module_v1 - subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & - lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & - pa_rf_in, tau_rf_in) + subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, & + cgwf, pa_rf_in, tau_rf_in, errmsg, errflg) ! ! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 ! @@ -201,11 +196,14 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & real, intent (in) :: ak(levs+1), bk(levs+1), pref real, intent (in) :: dtp real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW dims(2) !!! - real, intent (in) :: pa_rf_in, tau_rf_in + real, intent (in) :: pa_rf_in, tau_rf_in, con_pi, con_rerth character(len=64), intent (in) :: fn_nml2 character(len=64), parameter :: fn_nml='input.nml' + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! character, intent (in) :: input_nml_file ! integer, parameter :: logunit = 6 integer :: ios @@ -215,8 +213,7 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & integer :: ncid, iernc, vid, dimid, status integer :: k integer :: ddd_ugwp, curday_ugwp - real :: avqbo(6) - avqbo = [0.05, 0.1, 0.25, 0.5, 0.75, 0.95] + real, dimension(6) :: avqbo = (/0.05, 0.1, 0.25, 0.5, 0.75, 0.95/) ! if (me == master) print *, trim (fn_nml), ' GW-namelist file ' inquire (file =trim (fn_nml) , exist = exists) @@ -231,6 +228,12 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & read (nlunit, nml = cires_ugwp_nml) close (nlunit) ! + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + strsolver= knob_ugwp_orosolv pa_rf = pa_rf_in tau_rf = tau_rf_in @@ -304,7 +307,8 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & ! ! Part-1 :init_global_gwdis_v1 ! - call init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, pa_rf, tau_rf, me, master) + call init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + pa_rf, tau_rf, me, master) call rf_damp_init_v1 (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) ! ! Part-2 :init_SOURCES_gws @@ -326,21 +330,24 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & if (knob_ugwp_wvspec(4) > 0) then ! okw call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) + knob_ugwp_stoch(4), knob_ugwp_effac(4), & + con_pi, lonr, kxw ) if (me == master) print *, ' init_okw_gws ' endif if (knob_ugwp_wvspec(3) > 0) then ! fronts call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) + knob_ugwp_stoch(3), knob_ugwp_effac(3), & + con_pi, lonr, kxw ) if (me == master) print *, ' init_fjet_gws ' endif if (knob_ugwp_wvspec(2) > 0) then ! conv call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) + knob_ugwp_stoch(2), knob_ugwp_effac(2), & + con_pi, con_rerth, lonr, kxw, cgwf ) if (me == master) & print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) @@ -356,10 +363,10 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) if(iernc.ne.0) then - write(6,*) - write(6,*) ' cannot open file_limb_tab data-file', trim(ugwp_taufile) - write(6,*) - stop + write(errmsg,'(*(a))') "Cannot open file_limb_tab data-file ", & + trim(ugwp_taufile) + errflg = 1 + return else @@ -388,10 +395,10 @@ subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & iernc=NF90_OPEN(trim(ugwp_qbofile), nf90_nowrite, ncid) if(iernc.ne.0) then - write(6,*) - write(6,*) ' cannot open qbofile data-file', trim(ugwp_qbofile) - write(6,*) - stop + write(errmsg,'(*(a))') "Cannot open qbofile data-file ", & + trim(ugwp_qbofile) + errflg = 1 + return else status = nf90_inq_dimid(ncid, "lat", DimID) diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 index e6c3a1ea0..fd692a825 100644 --- a/physics/cires_ugwp_orolm97_v1.F90 +++ b/physics/cires_ugwp_orolm97_v1.F90 @@ -8,7 +8,8 @@ module cires_ugwp_orolm97_v1 subroutine gwdps_oro_v1(im, km, imx, do_tofd, & pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & - oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, sgh30, & + oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, & + grav, con_omega, rd, cpd, rv, pi, arad, fv, sgh30, & dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & cdmbgwd, me, master, rdxzb, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & @@ -23,10 +24,7 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & !---------------------------------------- use machine , only : kind_phys - use ugwp_common_v1, only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2, & - pi, rad_to_deg, deg_to_rad, pi2, & - rdi, gor, grcp, gocp, fv, gr2, & - bnv2min, dw2min, velmin, arad + use ugwp_common_v1, only : dw2min, velmin use ugwp_oro_init_v1, only : rimin, ric, efmin, efmax , & hpmax, hpmin, sigfaci => sigfac , & @@ -70,6 +68,8 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & clx4(im,4), theta(im), sigmad(im), & gammad(im), elvmaxd(im) + real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, & + pi, arad, fv real(kind=kind_phys), intent(in) :: sgh30(im) real(kind=kind_phys), intent(in), dimension(im,km) :: & u1, v1, t1, q1,del, prsl, prslk, zmet @@ -166,6 +166,10 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 real(kind=kind_phys) :: belps, aelps, nhills, selps + + real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: pi2, rdi, gor, grcp, gocp, gr2, bnv2min + ! ! various integers ! @@ -181,6 +185,19 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & ! rcpdt = 1.0 / (cpd*dtp) grav2 = grav + grav +! + rgrav = 1.0/grav + rcpd = 1.0/cpd + rcpd2 = 0.5/cpd + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + pi2 = 2.*pi + rdi = 1.0/rd + gor = grav/rd + grcp = grav*rcpd + gocp = grcp + gr2 = grav*gor + bnv2min = (pi2/1800.)*(pi2/1800.) ! ! mtb-blocking sigma_min and dxres => cires_initialize ! @@ -813,6 +830,7 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, con_omega, rd, & del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) endif ! oro_wam_2017 - linsatdis-solver of wam-2017 @@ -840,7 +858,7 @@ subroutine gwdps_oro_v1(im, km, imx, do_tofd, & vp1(k) = v1(j,k) enddo - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, & + call ugwp_tofd1d(km, cpd, sigflt, elvmaxd(j), zsurf, zpbl, & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) do k=1,km diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 index c84028199..46a5fb833 100644 --- a/physics/cires_ugwp_solv2_v1_mod.F90 +++ b/physics/cires_ugwp_solv2_v1_mod.F90 @@ -11,8 +11,9 @@ module cires_ugwp_solv2_v1_mod ! they are out of given column !--------------------------------------------------- subroutine cires_ugwp_solv2_v1(im, levs, dtp , & - tm , um, vm, qm, prsl, prsi, zmet, zmeti, & + tm , um, vm, qm, prsl, prsi, zmet, zmeti, & prslk, xlatd, sinlat, coslat, & + grav, cpd, rd, rv, omega, pi, fv, & pdudt, pdvdt, pdtdt, dked, tauabs, wrms, trms, & tau_ngw, mpi_id, master, kdt) ! @@ -30,12 +31,7 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - use ugwp_common_v1 , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & - omega2, rcpd, rcpd2, pi, pi2, fv, & - rad_to_deg, deg_to_rad, & - rdi, gor, grcp, gocp, & - bnv2min, bnv2max, dw2min, velmin, gr2, & - hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min + use ugwp_common_v1 , only : dw2min, velmin, hpscale, rhp, rh4 ! use ugwp_wmsdis_init_v1, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & @@ -67,6 +63,8 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & real ,intent(in) :: tau_ngw(im) integer, intent(in):: mpi_id, master, kdt + + real ,intent(in) :: grav, cpd, rd, rv, omega, pi, fv ! ! ! out-gw effects @@ -144,7 +142,10 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & real :: pwrms, ptrms real :: zu, zcin, zcin2, zcin3, zcin4, zcinc real :: zatmp, fluxs, zdep, ze1, ze2 - +! + real :: rcpdl, grav2cpd, rcpd, rcpd2, pi2, rad_to_deg + real :: deg_to_rad, rdi, gor, grcp, gocp, bnv2min, bnv2max, gr2 + real :: grav2, rgrav, rgrav2, mkzmin, mkz2min ! real :: zdelp, zdelm, taud_min real :: tvc, tvm, ptc, ptm @@ -192,9 +193,27 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & tauabs=0.0; wrms =0.0 ; trms =0.0 endif -! grav2 = grav + grav -! rgrav2 = rgrav*rgrav - + + grav2 = grav + grav + rgrav = 1.0/grav + rgrav2 = rgrav*rgrav + rdi = 1.0/rd + gor = grav/rd + gr2 = grav*gor + rcpd = 1.0/cpd + rcpd2 = 0.5/cpd + rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + pi2 = 2.0*pi + grcp = grav*rcpd + gocp = grcp + grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + bnv2min = (pi2/1800.)*(pi2/1800.) + bnv2max = (pi2/30.)*(pi2/30.) + mkzmin = pi2/80.0e3 + mkz2min = mkzmin*mkzmin + rci(:) = 1./zci(:) rdci(:) = 1./zdci(:) @@ -224,7 +243,7 @@ subroutine cires_ugwp_solv2_v1(im, levs, dtp , & DO j=1, im jl =j - tx1 = omega2 * sinlat(j) *rv_kxw + tx1 = 2*omega * sinlat(j) *rv_kxw cf1 = abs(tx1) c2f2 = tx1 * tx1 ucrit_max = max(ucrit, cf1) diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 index 44911e1d5..8cfd57cb7 100644 --- a/physics/cires_ugwp_triggers_v1.F90 +++ b/physics/cires_ugwp_triggers_v1.F90 @@ -9,24 +9,25 @@ subroutine ugwp_triggers write(6,*) ' physics-based triggers for UGWP ' end subroutine ugwp_triggers ! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, earth_r, & cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - use ugwp_common_v1 , only : deg_to_rad implicit none integer :: nx, ny real :: lon(nx), lat(ny) real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: earth_r, ra1, ra2, dx, dy, dlat + real :: ra1, ra2, dx, dy, dlat + real :: con_pi, earth_r real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) integer :: j + real :: deg_to_rad ! ! specify common constants and ! geometric factors to compute deriv-es etc ... ! coriolis coslat tan etc... ! - earth_r = 6370.e3 + deg_to_rad = con_pi/180.0 ra1 = 1.0 / earth_r ra2 = ra1*ra1 ! @@ -125,10 +126,12 @@ subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) end subroutine get_xyd_wind - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & + con_pi, con_rerth, pmid, trig3d_fgf) implicit none integer :: nx, ny, nz real :: lon(nx), lat(ny) + real :: con_pi, con_rerth ! real, dimension(nz) :: pmid real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d @@ -150,7 +153,7 @@ subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) do k=1, nz @@ -173,6 +176,7 @@ subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, implicit none integer :: nx, ny, nz real :: lon(nx), lat(ny) + real :: con_pi, con_rerth ! real, dimension(nz) :: pmid real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d @@ -193,7 +197,7 @@ subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, real :: dx, dy, dlat real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) do k=1, nz @@ -238,12 +242,13 @@ end subroutine trig3d_dconv subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - trig3d_okw, trig3d_fgf, trig3d_conv, & + con_pi, con_rerth, trig3d_okw, trig3d_fgf, trig3d_conv, & dcheat3d, precip2d, cld_klevs2d, scheat3d) implicit none integer :: nx, ny, nz real :: lon(nx), lat(ny) + real :: con_pi, con_rerth ! ! reversed ??? Hyai, Hybi , pmid ! @@ -265,7 +270,8 @@ subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & ! !=================================================================================== - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & + con_pi, con_rerth, pmid, trig3d_fgf) call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & dcheat3d, precip2d, cld_klevs2d, scheat3d) @@ -544,13 +550,15 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) enddo ! end subroutine slat_geos5 - subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common_v1 , only : pi2 + subroutine init_nazdir(con_pi, naz, xaz, yaz) implicit none + real :: con_pi integer :: naz real, dimension(naz) :: xaz, yaz integer :: idir real :: phic, drad + real :: pi2 + pi2 = 2.0*con_pi drad = pi2/float(naz) if (naz.ne.4) then do idir =1, naz diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 index c328a3fb6..d16b1519f 100644 --- a/physics/cires_vert_orodis_v1.F90 +++ b/physics/cires_vert_orodis_v1.F90 @@ -766,15 +766,15 @@ end subroutine ugwp_taub_oro ! !-------------------------------------- ! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & -! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & -! xn, yn, umag, drtau, kdis_oro) +! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, & +! con_pi, con_g, kxw, fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, & +! pmid1, pint1, xn, yn, umag, drtau, kdis_oro) subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - xn, yn, umag, drtau, kdis) + pi, grav, kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, xn, yn, umag, drtau, kdis) - use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav + use ugwp_common_v1, only : dw2min, velmin use cires_ugwp_module_v1, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 use cires_ugwp_module_v1, only : kvg, ktg, krad, kion use ugwp_oro_init_v1, only : coro , fcrit_sm , fcrit_sm2 @@ -786,6 +786,8 @@ subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & real , dimension(levs+1) :: tau_src + real, intent(in) :: pi, grav + real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm real, dimension(levs+1), intent(in) :: zpi, pmid, pint real , intent(in) :: xn, yn, umag @@ -796,6 +798,7 @@ subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & ! ! locals ! + real :: bnv2min, pi2, rgrav real :: uref, udir, uf2, ufd, uf2p real, dimension(levs+1) :: tauz real, dimension(levs) :: rho @@ -809,6 +812,10 @@ subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & real :: betadis, betam, betat, cdfm, cdft real :: fsat, hsat, hsat2, kds , c2f2 + pi2 = 2.0*pi + bnv2min = (pi2/1800.)*(pi2/1800.) + rgrav = 1.0/grav + drtau(1:levs) = 0.0 kdis (1:levs) = 0.0 @@ -931,15 +938,15 @@ subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & end subroutine ugwp_oro_lsatdis ! ! - subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & + subroutine ugwp_tofd(im, levs, con_cp, sigflt, elvmax, zpbl, u, v, zmid, & utofd, vtofd, epstofd, krf_tofd) use machine , only : kind_phys - use ugwp_common_v1 , only : rcpd2 use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd ! implicit none ! integer :: im, levs + real(kind_phys) :: con_cp real(kind_phys), dimension(im, levs) :: u, v, zmid real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd @@ -947,10 +954,12 @@ subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & ! locals ! integer :: i, k + real :: rcpd2 real :: sgh = 30. real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf ! utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp ! do i=1, im @@ -979,14 +988,14 @@ subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & end subroutine ugwp_tofd ! ! - subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & + subroutine ugwp_tofd1d(levs, con_cp, sigflt, elvmax, zsurf, zpbl, u, v, & zmid, utofd, vtofd, epstofd, krf_tofd) use machine , only : kind_phys - use ugwp_common_v1 , only : rcpd2 use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd ! implicit none integer :: levs + real(kind_phys) :: con_cp real(kind_phys), dimension(levs) :: u, v, zmid real(kind_phys) :: sigflt, elvmax, zpbl, zsurf real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd @@ -994,10 +1003,12 @@ subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & ! locals ! integer :: i, k + real :: rcpd2 real :: sghmax = 5. real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf ! utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp ! zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl zdec = min(ze_tofd, zdec) ! cannot exceed 18 km diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index f573c8776..3e3411fa8 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -31,7 +31,8 @@ subroutine cires_ugwp_driver_v0(me, master, ! (similar to WAM-2017) !----------------------------------------------------------- use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv + use physcons, only : con_cp, con_g, con_rd, con_rv, & + con_omega use ugwp_wmsdis_init, only : tamp_mpa, ilaunch use sso_coorde, only : pgwd, pgwd4, debugprint @@ -121,6 +122,7 @@ subroutine cires_ugwp_driver_v0(me, master, & SIGMA, GAMM, ELVMAX, & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, & cdmbgwd(1:2), me, master, rdxzb, + & con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & du3dt_mtb, du3dt_ogw, du3dt_tms) ! @@ -287,7 +289,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, & DUSFC, DVSFC, xlatd, sinlat, coslat, sparea, - $ cdmbgwd, me, master, rdxzb, + & cdmbgwd, me, master, rdxzb, + & con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & dudt_mtb, dudt_ogw, dudt_tms) !---------------------------------------- @@ -341,6 +344,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys), intent(in) :: ELVMAXD(IM), THETA(IM) real(kind=kind_phys), intent(in) :: vSIGMA(IM), vGAMMA(IM) real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) + + real(kind=kind_phys), intent(in) :: con_g, con_omega !output -phys-tend real(kind=kind_phys),dimension(im,km),intent(out) :: @@ -1066,6 +1071,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, + & con_g, con_omega, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 13b9f9193..fda887f3e 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -74,10 +74,10 @@ module unified_ugwp ! subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & - pa_rf_in, tau_rf_in, con_p0, do_ugwp, do_ugwp_v0, & - do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, & - errmsg, errflg) + con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & + do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, errmsg, errflg) !---- initialization of unified_ugwp implicit none @@ -95,7 +95,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & real(kind=kind_phys), intent (in) :: dtp real(kind=kind_phys), intent (in) :: cdmbgwd(4), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in - real(kind=kind_phys), intent (in) :: con_p0 + real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth logical, intent (in) :: do_ugwp logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & @@ -156,9 +156,10 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v1 ) then - call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, & - fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & - cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & + con_p0, dtp, cdmbgwd(1:2), cgwf, pa_rf_in, & + tau_rf_in, errmsg, errflg) end if is_initialized = .true. @@ -171,11 +172,11 @@ end subroutine unified_ugwp_init ! ----------------------------------------------------------------------- !>@brief The subroutine finalizes the CIRES UGWP -#if 0 + !> \section arg_table_unified_ugwp_finalize Argument Table !! \htmlinclude unified_ugwp_finalize.html !! -#endif + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) implicit none @@ -229,8 +230,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & - dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & - rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + dudt, dvdt, dtdt, rdxzb, con_g, con_omega, con_pi, con_cp, con_rd, con_rv, & + con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & @@ -288,7 +289,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & + con_rv, con_rerth, con_fvirt real(kind=kind_phys), intent(in), dimension(im) :: rain @@ -397,10 +399,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & clx, theta, sigma, gamma, elvmax, & - sgh30, DUSFCg, DVSFCg, xlat_d, sinlat, coslat, & - area,cdmbgwd(1:2), me, master, rdxzb, & - zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - du3dt_mtb, du3dt_ogw, du3dt_tms) + con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & + con_rerth, con_fvirt, sgh30, DUSFCg, DVSFCg, & + xlat_d, sinlat, coslat, area,cdmbgwd(1:2), me, & + master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, du3dt_mtb, du3dt_ogw, du3dt_tms) end if @@ -663,6 +666,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, call cires_ugwp_solv2_v1(im, levs, dtp, & tgrs, ugrs, vgrs, q1, prsl, prsi, & zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + con_g, con_cp, con_rd, con_rv, con_omega, & + con_pi, con_fvirt, & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & tauabs, wrms, trms, tau_ngw, me, master, kdt) diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 28aa196d3..49f9365fd 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -138,6 +138,24 @@ kind = kind_phys intent = in optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [pa_rf_in] standard_name = pressure_cutoff_for_rayleigh_damping long_name = pressure level from which Rayleigh Damping is applied @@ -1067,6 +1085,15 @@ kind = kind_phys intent = in optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter @@ -1103,6 +1130,15 @@ kind = kind_phys intent = in optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [con_fvirt] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 index 5e43f2830..39de4b475 100644 --- a/physics/unified_ugwp_post.F90 +++ b/physics/unified_ugwp_post.F90 @@ -12,11 +12,11 @@ subroutine unified_ugwp_post_init () end subroutine unified_ugwp_post_init !>@brief The subroutine initializes the unified UGWP -#if 0 + !> \section arg_table_unified_ugwp_post_run Argument Table !! \htmlinclude unified_ugwp_post_run.html !! -#endif + subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & From 73f06a3273f13077d73673eeb180e51c2ea90911 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 26 Oct 2020 23:14:46 +0000 Subject: [PATCH 41/45] Modified code per G. Firl's PR recommendations --- physics/cires_vert_orodis_v1.F90 | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 index d16b1519f..9638abc56 100644 --- a/physics/cires_vert_orodis_v1.F90 +++ b/physics/cires_vert_orodis_v1.F90 @@ -37,6 +37,9 @@ subroutine ugwp_drag_mtb( iemax, nz, & real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid real, dimension(nz+1), intent(in) :: zpi, pint + + ! character(len=*), intent(out) :: errmsg + ! integer, intent(out) :: errflg ! real, dimension(nz+1) :: zpi_zero real, dimension(nz) :: zpm_zero @@ -51,7 +54,12 @@ subroutine ugwp_drag_mtb( iemax, nz, & phiang, ang, pe, ek, & cang, sang, ss2, cs2, zlen, dbtmp, & hamp, bgamm, cgamm - + + + ! Initialize CCPP error handling variables + ! errmsg = '' + ! errflg = 0 + !================================================== ! ! elvp + hprime <=>elvp + nridge*hprime, ns =2 @@ -77,11 +85,11 @@ subroutine ugwp_drag_mtb( iemax, nz, & mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - if (mtb_fix == 0.) then - print *, cdmb, sigma, hamp - print *, ' MTB == 0' - stop - endif + ! if (mtb_fix == 0.) then + ! write(errmsg,'(*(a))') cdmb, sigma, hamp, ' MTB == 0' + ! errflg = 1 + ! return + ! endif if (strver == 'vay_2018') then @@ -99,7 +107,14 @@ subroutine ugwp_drag_mtb( iemax, nz, & bn2, uhm, vhm, bn2hm, rhohm) umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - if (bn2hm .le. 0.0) then + ! if (bn2hm .le. 0.0) then + ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' + ! errflg = 1 + ! return + ! end if + + + print *, ' unstable MF for MTB -RETURN ' RETURN ! unstable PBL endif From 2cf01d008e8f26e858cdb520226b8e5b8be50375 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 27 Oct 2020 19:52:27 +0000 Subject: [PATCH 42/45] cires_vert_orodis_v1.F90 bug fix --- physics/cires_vert_orodis_v1.F90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 index 9638abc56..852c114b0 100644 --- a/physics/cires_vert_orodis_v1.F90 +++ b/physics/cires_vert_orodis_v1.F90 @@ -110,14 +110,9 @@ subroutine ugwp_drag_mtb( iemax, nz, & ! if (bn2hm .le. 0.0) then ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' ! errflg = 1 - ! return + ! return ! unstable PBL ! end if - - - print *, ' unstable MF for MTB -RETURN ' - RETURN ! unstable PBL - endif bnmag =sqrt(bn2hm) frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. From 5964c9811e5452699717ae008487e21772f08083 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 16 Nov 2020 15:11:40 -0700 Subject: [PATCH 43/45] Bugfix in cires_ugwp.{F90,meta}: pass missing constants to GWDPS_V0 --- physics/cires_ugwp.F90 | 8 ++++---- physics/cires_ugwp.meta | 9 +++++++++ physics/ugwp_driver_v0.F | 5 ++--- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index f24ae39ae..21b331041 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -155,7 +155,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & - rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + con_omega, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, errmsg, errflg) @@ -192,7 +192,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, con_omega real(kind=kind_phys), intent(in), dimension(im) :: rain @@ -245,8 +245,8 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & - me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - dudt_mtb, dudt_ogw, dudt_tms) + me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) else ! calling old GFS gravity wave drag as is diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index ca1e573ba..133cd5b1d 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -806,6 +806,15 @@ kind = kind_phys intent = in optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [rain] standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep long_name = total rain at this time step diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index 3e3411fa8..c47079992 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,4 +1,4 @@ -!!23456 +! module sso_coorde ! ! specific to COORDE-2019 project OGW switches/sensitivity @@ -289,8 +289,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, & DUSFC, DVSFC, xlatd, sinlat, coslat, sparea, - & cdmbgwd, me, master, rdxzb, - & con_g, con_omega, + & cdmbgwd, me, master, rdxzb, con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & dudt_mtb, dudt_ogw, dudt_tms) !---------------------------------------- From af316340e3337e45cde702929388d3b005c75c31 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 18 Nov 2020 14:36:40 -0700 Subject: [PATCH 44/45] Change horizontal_dimension to horizontal_loop_extent in several new/modified schemes --- physics/tracer_sanitizer.meta | 2 +- physics/unified_ugwp.meta | 164 ++++++++++++++++----------------- physics/unified_ugwp_post.F90 | 8 +- physics/unified_ugwp_post.meta | 66 ++++++------- 4 files changed, 112 insertions(+), 128 deletions(-) diff --git a/physics/tracer_sanitizer.meta b/physics/tracer_sanitizer.meta index 0378911ed..e41d5d03d 100644 --- a/physics/tracer_sanitizer.meta +++ b/physics/tracer_sanitizer.meta @@ -12,7 +12,7 @@ standard_name = tracer_concentration_updated_by_physics long_name = tracer concentration updated by physics units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers) + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) type = real kind = kind_phys intent = inout diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 49f9365fd..675a68edd 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -383,7 +383,7 @@ standard_name = orography long_name = orography units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -392,7 +392,7 @@ standard_name = orography_unfiltered long_name = unfiltered orography units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -401,7 +401,7 @@ standard_name = standard_deviation_of_subgrid_orography long_name = standard deviation of subgrid orography units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -418,7 +418,7 @@ standard_name = convexity_of_subgrid_orography long_name = convexity of subgrid orography units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -427,7 +427,7 @@ standard_name = angle_from_east_of_maximum_subgrid_orographic_variations long_name = angle with_respect to east of maximum subgrid orographic variations units = degree - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -436,7 +436,7 @@ standard_name = slope_of_subgrid_orography long_name = slope of subgrid orography units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -445,7 +445,7 @@ standard_name = anisotropy_of_subgrid_orography long_name = anisotropy of subgrid orography units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -454,7 +454,7 @@ standard_name = maximum_subgrid_orography long_name = maximum of subgrid orography units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -463,7 +463,7 @@ standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height units = frac - dimensions = (horizontal_dimension,4) + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -472,7 +472,7 @@ standard_name = asymmetry_of_subgrid_orography long_name = asymmetry of subgrid orography units = none - dimensions = (horizontal_dimension,4) + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -481,7 +481,7 @@ standard_name = standard_deviation_of_subgrid_orography_small_scale long_name = standard deviation of subgrid orography small scale units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -490,7 +490,7 @@ standard_name = convexity_of_subgrid_orography_small_scale long_name = convexity of subgrid orography small scale units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -499,7 +499,7 @@ standard_name = asymmetry_of_subgrid_orography_small_scale long_name = asymmetry of subgrid orography small scale units = none - dimensions = (horizontal_dimension,4) + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -508,7 +508,7 @@ standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height small scale units = frac - dimensions = (horizontal_dimension,4) + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -517,7 +517,7 @@ standard_name = cell_size long_name = size of the grid cell units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -526,7 +526,7 @@ standard_name = integrated_x_momentum_flux_from_large_scale_gwd long_name = integrated x momentum flux from large scale gwd units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -535,7 +535,7 @@ standard_name = integrated_y_momentum_flux_from_large_scale_gwd long_name = integrated y momentum flux from large scale gwd units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -544,7 +544,7 @@ standard_name = integrated_x_momentum_flux_from_blocking_drag long_name = integrated x momentum flux from blocking drag units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -553,7 +553,7 @@ standard_name = integrated_y_momentum_flux_from_blocking_drag long_name = integrated y momentum flux from blocking drag units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -562,7 +562,7 @@ standard_name = integrated_x_momentum_flux_from_small_scale_gwd long_name = integrated x momentum flux from small scale gwd units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -571,7 +571,7 @@ standard_name = integrated_y_momentum_flux_from_small_scale_gwd long_name = integrated y momentum flux from small scale gwd units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -580,7 +580,7 @@ standard_name = integrated_x_momentum_flux_from_form_drag long_name = integrated x momentum flux from form drag units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -589,7 +589,7 @@ standard_name = integrated_y_momentum_flux_from_form_drag long_name = integrated y momentum flux from form drag units = Pa s - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -598,7 +598,7 @@ standard_name = x_momentum_tendency_from_large_scale_gwd long_name = x momentum tendency from large scale gwd units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -607,7 +607,7 @@ standard_name = y_momentum_tendency_from_large_scale_gwd long_name = y momentum tendency from large scale gwd units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -616,7 +616,7 @@ standard_name = x_momentum_tendency_from_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -625,7 +625,7 @@ standard_name = y_momentum_tendency_from_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -634,7 +634,7 @@ standard_name = x_momentum_tendency_from_small_scale_gwd long_name = x momentum tendency from small scale gwd units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -643,7 +643,7 @@ standard_name = y_momentum_tendency_from_small_scale_gwd long_name = y momentum tendency from small scale gwd units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -652,7 +652,7 @@ standard_name = x_momentum_tendency_from_form_drag long_name = x momentum tendency from form drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -661,7 +661,7 @@ standard_name = y_momentum_tendency_from_form_drag long_name = y momentum tendency from form drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -670,7 +670,7 @@ standard_name = bulk_richardson_number_at_lowest_model_level long_name = bulk Richardson number at the surface units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -679,7 +679,7 @@ standard_name = atmosphere_boundary_layer_thickness long_name = PBL thickness units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -688,7 +688,7 @@ standard_name = sea_land_ice_mask_real long_name = landmask: sea/land/ice=0/1/2 units = flag - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -728,7 +728,7 @@ standard_name = latitude long_name = grid latitude units = radian - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -737,7 +737,7 @@ standard_name = latitude_in_degree long_name = latitude in degree north units = degree_north - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -746,7 +746,7 @@ standard_name = sine_of_latitude long_name = sine of the grid latitude units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -755,7 +755,7 @@ standard_name = cosine_of_latitude long_name = cosine of the grid latitude units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -764,7 +764,7 @@ standard_name = cell_area long_name = area of the grid cell units = m2 - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -773,7 +773,7 @@ standard_name = x_wind long_name = zonal wind units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -782,7 +782,7 @@ standard_name = y_wind long_name = meridional wind units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -791,7 +791,7 @@ standard_name = air_temperature long_name = model layer mean temperature units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -800,7 +800,7 @@ standard_name = water_vapor_specific_humidity long_name = mid-layer specific humidity of water vapor units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -809,7 +809,7 @@ standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces units = Pa - dimensions = (horizontal_dimension,vertical_dimension_plus_one) + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys intent = in @@ -818,7 +818,7 @@ standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -827,7 +827,7 @@ standard_name = dimensionless_exner_function_at_model_layers long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -836,7 +836,7 @@ standard_name = geopotential_at_interface long_name = geopotential at model layer interfaces units = m2 s-2 - dimensions = (horizontal_dimension,vertical_dimension_plus_one) + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys intent = in @@ -845,7 +845,7 @@ standard_name = geopotential long_name = geopotential at model layer centers units = m2 s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -854,7 +854,7 @@ standard_name = air_pressure_difference_between_midlayers long_name = air pressure difference between midlayers units = Pa - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -863,7 +863,7 @@ standard_name = vertical_index_at_top_of_atmosphere_boundary_layer long_name = vertical index at top atmospheric boundary layer units = index - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = integer intent = in optional = F @@ -871,7 +871,7 @@ standard_name = instantaneous_x_stress_due_to_gravity_wave_drag long_name = zonal surface stress due to orographic gravity wave drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -880,7 +880,7 @@ standard_name = instantaneous_y_stress_due_to_gravity_wave_drag long_name = meridional surface stress due to orographic gravity wave drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -891,7 +891,7 @@ standard_name = tendency_of_x_wind_due_to_ugwp long_name = zonal wind tendency due to UGWP units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -900,7 +900,7 @@ standard_name = tendency_of_y_wind_due_to_ugwp long_name = meridional wind tendency due to UGWP units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -909,7 +909,7 @@ standard_name = tendency_of_air_temperature_due_to_ugwp long_name = air temperature tendency due to UGWP units = K s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -918,7 +918,7 @@ standard_name = eddy_mixing_due_to_ugwp long_name = eddy mixing due to UGWP units = m2 s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -927,7 +927,7 @@ standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag long_name = momentum flux or stress due to TOFD units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -936,7 +936,7 @@ standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag long_name = momentum flux or stress due to mountain blocking drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -945,7 +945,7 @@ standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag long_name = momentum flux or stress due to orographic gravity wave drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -954,7 +954,7 @@ standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave long_name = momentum flux or stress due to nonstationary gravity waves units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -963,7 +963,7 @@ standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -972,7 +972,7 @@ standard_name = height_of_low_level_wave_breaking long_name = height of low level wave breaking units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -981,7 +981,7 @@ standard_name = height_of_launch_level_of_orographic_gravity_wave long_name = height of launch level of orographic gravity wave units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -990,7 +990,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag long_name = instantaneous change in x wind due to mountain blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -999,7 +999,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -1008,7 +1008,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = out @@ -1017,7 +1017,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag long_name = time integral of change in x wind due to mountain blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1026,7 +1026,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = time integral of change in x wind due to orographic gw drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1035,7 +1035,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag long_name = time integral of change in x wind due to TOFD units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1044,7 +1044,7 @@ standard_name = tendency_of_x_wind_due_to_model_physics long_name = zonal wind tendency due to model physics units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1053,7 +1053,7 @@ standard_name = tendency_of_y_wind_due_to_model_physics long_name = meridional wind tendency due to model physics units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1062,7 +1062,7 @@ standard_name = tendency_of_air_temperature_due_to_model_physics long_name = air temperature tendency due to model physics units = K s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1071,7 +1071,7 @@ standard_name = level_of_dividing_streamline long_name = level of the dividing streamline units = none - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out @@ -1152,7 +1152,7 @@ standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep long_name = total rain at this time step units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -1169,7 +1169,7 @@ standard_name = turbulent_kinetic_energy long_name = turbulent kinetic energy units = J - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -1178,7 +1178,7 @@ standard_name = tendency_of_turbulent_kinetic_energy_due_to_model_physics long_name = turbulent kinetic energy tendency due to model physics units = J s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -1203,7 +1203,7 @@ standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = cumulative change in x wind due to orographic gravity wave drag units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1212,7 +1212,7 @@ standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag long_name = cumulative change in y wind due to orographic gravity wave drag units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1221,7 +1221,7 @@ standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag long_name = cumulative change in temperature due to orographic gravity wave drag units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1230,7 +1230,7 @@ standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag long_name = cumulative change in x wind due to convective gravity wave drag units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1239,7 +1239,7 @@ standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag long_name = cumulative change in y wind due to convective gravity wave drag units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1248,7 +1248,7 @@ standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag long_name = cumulative change in temperature due to convective gravity wave drag units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 index 39de4b475..3af459d76 100644 --- a/physics/unified_ugwp_post.F90 +++ b/physics/unified_ugwp_post.F90 @@ -6,8 +6,7 @@ module unified_ugwp_post !>\defgroup unified_ugwp_post unified_UGWP Scheme Post !! @{ -!> \section arg_table_unified_ugwp_post_init Argument Table -!! + subroutine unified_ugwp_post_init () end subroutine unified_ugwp_post_init @@ -16,9 +15,6 @@ end subroutine unified_ugwp_post_init !> \section arg_table_unified_ugwp_post_run Argument Table !! \htmlinclude unified_ugwp_post_run.html !! - - - subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & gw_dtdt, gw_dudt, gw_dvdt, tau_tofd, tau_mtb, tau_ogw, & tau_ngw, zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & @@ -74,8 +70,6 @@ subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & end subroutine unified_ugwp_post_run -!> \section arg_table_unified_ugwp_post_finalize Argument Table -!! subroutine unified_ugwp_post_finalize () end subroutine unified_ugwp_post_finalize diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index 501e91b8f..85a6bff8e 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -3,11 +3,6 @@ type = scheme dependencies = machine.F -######################################################################## -[ccpp-arg-table] - name = unified_ugwp_post_init - type = scheme - ######################################################################## [ccpp-arg-table] name = unified_ugwp_post_run @@ -49,7 +44,7 @@ standard_name = tendency_of_air_temperature_due_to_ugwp long_name = air temperature tendency due to UGWP units = K s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -58,7 +53,7 @@ standard_name = tendency_of_x_wind_due_to_ugwp long_name = zonal wind tendency due to UGWP units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -67,7 +62,7 @@ standard_name = tendency_of_y_wind_due_to_ugwp long_name = meridional wind tendency due to UGWP units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -76,7 +71,7 @@ standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag long_name = momentum flux or stress due to TOFD units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -85,7 +80,7 @@ standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag long_name = momentum flux or stress due to mountain blocking drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -94,7 +89,7 @@ standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag long_name = momentum flux or stress due to orographic gravity wave drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -103,7 +98,7 @@ standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave long_name = momentum flux or stress due to nonstationary gravity waves units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -112,7 +107,7 @@ standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -121,7 +116,7 @@ standard_name = height_of_low_level_wave_breaking long_name = height of low level wave breaking units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -130,7 +125,7 @@ standard_name = height_of_launch_level_of_orographic_gravity_wave long_name = height of launch level of orographic gravity wave units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in @@ -139,7 +134,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag long_name = instantaneous change in x wind due to mountain blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -148,7 +143,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -157,7 +152,7 @@ standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = in @@ -166,7 +161,7 @@ standard_name = time_integral_of_height_of_mountain_blocking long_name = time integral of height of mountain blocking drag units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -175,7 +170,7 @@ standard_name = time_integral_of_height_of_low_level_wave_breaking long_name = time integral of height of drag due to low level wave breaking units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -184,7 +179,7 @@ standard_name = time_integral_of_height_of_launch_level_of_orographic_gravity_wave long_name = time integral of height of launch level of orographic gravity wave units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -193,7 +188,7 @@ standard_name = time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag long_name = time integral of momentum flux due to TOFD units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -202,7 +197,7 @@ standard_name = time_integral_of_momentum_flux_due_to_mountain_blocking_drag long_name = time integral of momentum flux due to mountain blocking drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -211,7 +206,7 @@ standard_name = time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag long_name = time integral of momentum flux due to orographic gravity wave drag units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -220,7 +215,7 @@ standard_name = time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave long_name = time integral of momentum flux due to nonstationary gravity waves units = Pa - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -229,7 +224,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag long_name = time integral of change in x wind due to mountain blocking drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -238,7 +233,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = time integral of change in x wind due to orographic gw drag units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -247,7 +242,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag long_name = time integral of change in x wind due to TOFD units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -256,7 +251,7 @@ standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave long_name = time integral of change in x wind due to NGW units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -265,7 +260,7 @@ standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave long_name = time integral of change in y wind due to NGW units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -274,7 +269,7 @@ standard_name = tendency_of_air_temperature_due_to_model_physics long_name = air temperature tendency due to model physics units = K s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -283,7 +278,7 @@ standard_name = tendency_of_x_wind_due_to_model_physics long_name = zonal wind tendency due to model physics units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -292,7 +287,7 @@ standard_name = tendency_of_y_wind_due_to_model_physics long_name = meridional wind tendency due to model physics units = m s-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -314,8 +309,3 @@ type = integer intent = out optional = F - -######################################################################## -[ccpp-arg-table] - name = unified_ugwp_post_finalize - type = scheme From 551be294e2487d44731f38cf22814934a4d8967a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 19 Nov 2020 11:29:26 -0700 Subject: [PATCH 45/45] Bugfix in physics/cires_ugwp_module_v1.F90: remove unnecessary and ill-defined variable knob_ugwp_tlimb --- physics/cires_ugwp_module_v1.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 index 9b245ed11..fd41d8175 100644 --- a/physics/cires_ugwp_module_v1.F90 +++ b/physics/cires_ugwp_module_v1.F90 @@ -59,7 +59,6 @@ module cires_ugwp_module_v1 real :: knob_ugwp_taumin = 0.25e-3 real :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) real :: knob_ugwp_lhmet = 200.e3 ! 200 km - real :: knob_ugwp_tlimb = .true. ! real :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes ! @@ -102,7 +101,7 @@ module cires_ugwp_module_v1 knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & knob_ugwp_qbolev, knob_ugwp_qbosin, knob_ugwp_qbotav, knob_ugwp_qboamp, knob_ugwp_qbotau, & - knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_tlimb, knob_ugwp_orosolv + knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_orosolv !&cires_ugwp_nml ! knob_ugwp_solver=2