From 6d1994c8f37a4c410031e832875ba94a77c099a2 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Sat, 9 Jan 2021 19:47:02 -0500 Subject: [PATCH 01/16] update Jan 9 2021 from NCAR/ccpp-physics --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 33c8a984c..566bee9cd 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 33c8a984c17cf41be5d4c2928242e1b4239bfc40 +Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d From 7ddfb71983707d81252b3644cf0bafa340642942 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Sat, 9 Jan 2021 21:36:01 -0500 Subject: [PATCH 02/16] cires_ugwpv1*90 new ; ugwpv1_gsldrag* new unified_ugwp.* modified --- physics/cires_ugwpv1_initialize.F90 | 805 +++++++++++++++++ physics/cires_ugwpv1_module.F90 | 557 ++++++++++++ physics/cires_ugwpv1_oro.F90 | 1279 +++++++++++++++++++++++++++ physics/cires_ugwpv1_solv2.F90 | 1045 ++++++++++++++++++++++ physics/cires_ugwpv1_sporo.F90 | 353 ++++++++ physics/cires_ugwpv1_triggers.F90 | 446 ++++++++++ physics/ugwpv1_gsldrag.F90 | 671 ++++++++++++++ physics/ugwpv1_gsldrag.meta | 1265 ++++++++++++++++++++++++++ physics/ugwpv1_gsldrag_post.F90 | 107 +++ physics/ugwpv1_gsldrag_post.meta | 321 +++++++ physics/unified_ugwp.F90 | 205 +---- 11 files changed, 6857 insertions(+), 197 deletions(-) create mode 100644 physics/cires_ugwpv1_initialize.F90 create mode 100644 physics/cires_ugwpv1_module.F90 create mode 100644 physics/cires_ugwpv1_oro.F90 create mode 100644 physics/cires_ugwpv1_solv2.F90 create mode 100644 physics/cires_ugwpv1_sporo.F90 create mode 100644 physics/cires_ugwpv1_triggers.F90 create mode 100644 physics/ugwpv1_gsldrag.F90 create mode 100644 physics/ugwpv1_gsldrag.meta create mode 100644 physics/ugwpv1_gsldrag_post.F90 create mode 100644 physics/ugwpv1_gsldrag_post.meta diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/cires_ugwpv1_initialize.F90 new file mode 100644 index 000000000..1050da194 --- /dev/null +++ b/physics/cires_ugwpv1_initialize.F90 @@ -0,0 +1,805 @@ +!=============================== +! 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(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. + real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 + real(kind=kind_phys), parameter :: grav2 = grav + grav + real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 + real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd + real(kind=kind_phys), parameter :: gor = grav/rd + real(kind=kind_phys), parameter :: gr2 = grav*gor + real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp + real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + + real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi + real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 + + real(kind=kind_phys), parameter :: arad = 6370.e3 +! + real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) + real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) + + real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 + real(kind=kind_phys), parameter :: omega1 = pi2/86400. + real(kind=kind_phys), parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 + real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp + real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin + real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax + real(kind=kind_phys), 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, con_pi, & + me, master) +! +! ccpp-damn con_pi !!! +! +!non-ccpp subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +!non-ccpp use ugwp_common, only : pih + + use machine , only : kind_phys + + + implicit none + integer , intent(in) :: me, master + integer , intent(in) :: levs + real(kind=kind_phys), intent(in) :: con_pi + real(kind=kind_phys), intent(in) :: zkm(levs), pmb(levs) ! in km-Pa + real(kind=kind_phys), intent(out), dimension(levs+1) :: kvg, ktg, krad, kion +! +!locals + data +! + integer :: k + real(kind=kind_phys), parameter :: vusurf = 2.e-5 + real(kind=kind_phys), parameter :: musurf = vusurf/1.95 + real(kind=kind_phys), parameter :: hpmol = 7.0 +! + real(kind=kind_phys), parameter :: kzmin = 0.1 + real(kind=kind_phys), parameter :: kturbo = 100. + real(kind=kind_phys), parameter :: zturbo = 130. + real(kind=kind_phys), parameter :: zturw = 30. + real(kind=kind_phys), parameter :: inv_pra = 3. !kt/kv =inv_pr +! + real(kind=kind_phys), parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days + real(kind=kind_phys) :: pa_alp = 750. ! super-RF parameters from FV3-dycore GFSv17/16 sett + real(kind=kind_phys) :: tau_alp = 10. ! days (750 Pa /10days) +! + real(kind=kind_phys), parameter :: kdrag = 1./86400./30. !parametrization for WAM ion drag as e-density function + real(kind=kind_phys), parameter :: zdrag = 100. + real(kind=kind_phys), parameter :: zgrow = 50. +! + real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag + real(kind=kind_phys) :: rf_fv3, rtau_fv3, ptop, pih_dlog +! + real(kind=kind_phys) :: ae1 ,ae2 +! +! ccpp con_pi +! + real(kind=kind_phys) :: pih + pih = 0.5*con_pi + + 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) ... init_global_gwdis' + 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 +! +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init +! +!========================================================================= + module ugwp_oro_init + use machine , only : kind_phys + 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 +! +! + real(kind=kind_phys), parameter :: hncrit=9000. ! max value in meters for elvmax + real(kind=kind_phys), parameter :: hminmt=50. ! min mtn height (*j*) + real(kind=kind_phys), parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor + real(kind=kind_phys), parameter :: hpmax=2500.0 + real(kind=kind_phys), parameter :: hpmin=25.0 +! +! + real(kind=kind_phys), parameter :: minwnd=1.0 ! min wind component (*j*) + real(kind=kind_phys), parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + + + character(len=8) :: strver = 'gfs_2018' + character(len=8) :: strbase = 'gfs_2018' + real(kind=kind_phys), parameter :: rimin=-10., ric=0.25 + + real(kind=kind_phys), parameter :: frmax=10., frc =1.0, frmin =0.01 + real(kind=kind_phys), parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real(kind=kind_phys), parameter :: gmax=1.0, veleps=1.0, factop=0.5! + real(kind=kind_phys), parameter :: efmin=0.5, efmax=10.0 + + real(kind=kind_phys), parameter :: rlolev=50000.0 + integer,parameter :: mdir = 8 + real(kind=kind_phys), parameter :: fdir=.5*mdir/pi + + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir + + real(kind=kind_phys), parameter :: odmin = 0.1, odmax = 10.0 + real(kind=kind_phys), parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm + real(kind=kind_phys), parameter :: fcrit_gfs = 0.7, fcrit_v1 = 0.7 + real(kind=kind_phys), parameter :: fcrit_mtb = 0.7 + + real(kind=kind_phys), parameter :: zbr_pi = (1.0/2.0)*pi + real(kind=kind_phys), parameter :: zbr_ifs = 0.5*pi + +! + + real(kind=kind_phys), parameter :: kxoro=6.28e-3/200. ! + real(kind=kind_phys), parameter :: coro = 0.0 + integer,parameter :: nridge=2 + real(kind=kind_phys), parameter :: sigma_std=1./100., gamm_std=1.0 + + real(kind=kind_phys) :: cdmb ! scale factors for mtb + real(kind=kind_phys) :: cleff ! scale factors for orogw + + integer :: nworo ! number of waves + integer :: nazoro ! number of azimuths + integer :: nstoro ! flag for stochastic launch above SG-peak + + +!------------------------------------------------------------------------------ +! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS +! SA-option can be controlled by Integral limits of fluxes +! in B2004: klow = 0.003 1/m ~ 2km and kinf ~ 6.28/10/(Z1)~< 1 km => meters +! these limits can change strength of TOFD... choice of k0tr ~1/10 km (10km ~dx of C768) +! kmax = kdis_pbl +!------------------------------------------------------------------------------ + real(kind=kind_phys), parameter :: kmax = 6.28/(10.*25.) ! max k-tofd + real(kind=kind_phys), parameter :: k1tr = 6.28/(2100) ! max k-transition from -1.9/slope to -2.8/slope + real(kind=kind_phys), parameter :: kflt = 6.28/(18.e3) ! + real(kind=kind_phys), parameter :: k0tr = 6.28/(10.e3) ! min k-tofd + real(kind=kind_phys), parameter :: nk1tr = 2.8 + real(kind=kind_phys), parameter :: nk0tr = 1.9 + real(kind=kind_phys), parameter :: a1_tofd = kflt ** nk1tr *1.e3 + real(kind=kind_phys), parameter :: a2_tofd = k1tr ** (nk0tr-nk1tr) + real(kind=kind_phys), parameter :: fix_tofd = 2.* 0.005 * 12 *0.6 !value= 0.072 +! +! B2004 scheme is based on the empirical vertical profile of the tofd divergence: +! Ax_tofd(Z)=exp(-[Z/ze_tofd]^3/2) / Z^1.2..... +! TOFD-flux/TMS-flux must dissipate due to PBL-diffusion with spectral damping +! Here we can enhance TOFD-impact by selecting k0tr and kmax limits +! as functions of resolution and PBL-dissipation +! + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real(kind=kind_phys), parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real(kind=kind_phys), parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters, 1.5 km + real(kind=kind_phys), parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real(kind=kind_phys), parameter :: ztop_tofd = 3.*ze_tofd ! no TOFD > this height 4.5 km +!------------------------------------------------------------------------------ +! + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: cdmbX + real(kind=kind_phys) :: kxw + real(kind=kind_phys) :: 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(kind=kind_phys), parameter :: lonr_refmb = 4.0 * 192.0 + real(kind=kind_phys), parameter :: lonr_refgw = 192.0 + real(kind=kind_phys), parameter :: cleff_ref = 0.5e-5 ! 1256 km = 10 * 125 km ??? + +! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + + cdmb = cdmbX + cleff = cleff_ref * sqrt(lonr_refgw/float(lonr)) !* effac +! + end subroutine init_oro_gws +! + + end module ugwp_oro_init +! ========================================================================= +! +! ugwp_conv_init +! +!========================================================================= + module ugwp_conv_init + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + implicit none + real(kind=kind_phys) :: 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(kind=kind_phys) :: con_dlength + real(kind=kind_phys) :: con_cldf + + real(kind=kind_phys), parameter :: cmin = 5 !2.5 + real(kind=kind_phys), parameter :: cmax = 95. !82.5 + real(kind=kind_phys), parameter :: cmid = 22.5 + real(kind=kind_phys), parameter :: cwid = cmid + real(kind=kind_phys), parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real(kind=kind_phys), parameter :: mstar = 6.28e-3/2. ! 2km + real(kind=kind_phys) :: dc + + real(kind=kind_phys), allocatable :: ch_conv(:), spf_conv(:) + real(kind=kind_phys), allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & + con_pi, arad, lonr, kxw) +! +! non-ccpp with use ugwp_common +! +! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & +! lonr, kxw) +! +! use ugwp_common, only : pi2, arad + + + + implicit none + + + integer :: nwaves, nazdir, nstoch + integer :: lonr +! +! ccpp +! + real(kind=kind_phys) :: con_pi, arad + + real(kind=kind_phys) :: kxw, effac + real(kind=kind_phys) :: work1 = 0.5 + real(kind=kind_phys) :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = 2.0*con_pi*arad/float(lonr) +! +! 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(con_pi, nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init +!========================================================================= +! +! ugwp_fjet_init +! +!========================================================================= + + module ugwp_fjet_init + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + + implicit none + real(kind=kind_phys) :: 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(kind=kind_phys), parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_fjet(:) , spf_fjet(:) + real(kind=kind_phys), allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) +! non-ccpp +! +! 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(kind=kind_phys) :: con_pi + real(kind=kind_phys) :: 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(con_pi, nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init +! +!========================================================================= +! +! + module ugwp_okw_init +!========================================================================= + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + implicit none + + real(kind=kind_phys) :: 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(kind=kind_phys), parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_okwp(:), spf_okwp(:) + real(kind=kind_phys), allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) + +! 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(kind=kind_phys) :: con_pi + real(kind=kind_phys) :: 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(con_pi, nazdir, xaz_okwp, yaz_okwp) +! non-ccpp +! 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 + use machine , only : kind_phys + implicit none + + integer :: nwav, nazd + integer :: nst + real(kind=kind_phys) :: 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(kind=kind_phys) :: effac + logical :: do_physb + real(kind=kind_phys) :: 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 machine , only : kind_phys + 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(kind=kind_phys), parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 + real(kind=kind_phys), parameter :: dked_min =0.01, dked_max=250.0 + + real(kind=kind_phys), parameter :: gptwo=2.0 + + real(kind=kind_phys) , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real(kind=kind_phys) , parameter :: bnfix4 = bnfix2 * bnfix2 + real(kind=kind_phys) , parameter :: bnfix3 = bnfix2 * bnfix +! +! make parameter list that will be passed to SOLVER +! + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + real(kind=kind_phys) , parameter :: ucrit=cdmin + + real(kind=kind_phys) , parameter :: zcimin = 2.5 + real(kind=kind_phys) , parameter :: zcimax = 125.0 + real(kind=kind_phys) , parameter :: zgam = 0.25 +! +! Verical spectra +! + real(kind=kind_phys) , parameter :: pind_wd = 5./3. + real(kind=kind_phys) , parameter :: sind_kz = 1. + real(kind=kind_phys) , parameter :: tind_kz = 3. + real(kind=kind_phys) , parameter :: stind_kz = sind_kz + tind_kz +! +! copies from kmob_ugwp namelist +! + real(kind=kind_phys) :: nslope ! the GW sprctral slope at small-m + real(kind=kind_phys) :: lzstar + real(kind=kind_phys) :: lzmin + real(kind=kind_phys) :: lzmax + real(kind=kind_phys) :: lhmet + real(kind=kind_phys) :: tamp_mpa !amplitude for GEOS-5/MERRA-2 + real(kind=kind_phys) :: tau_min ! min of GW MF 0.25 mPa + integer :: ilaunch + real(kind=kind_phys) :: gw_eff + + real(kind=kind_phys) :: v_kxw, rv_kxw, v_kxw2 + + + +!=========================================================================== + integer :: nwav, nazd, nst + real(kind=kind_phys) :: eff + + real(kind=kind_phys) :: zaz_fct, zms + real(kind=kind_phys), allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real(kind=kind_phys), allocatable :: zcosang(:), zsinang(:) + real(kind=kind_phys), 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(kind=kind_phys), parameter :: iPr_pt = 0.5 + real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. + real(kind=kind_phys), parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable + real(kind=kind_phys), parameter :: ric =0.25 + real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 + real(kind=kind_phys), parameter :: prmax = 4.0 +! + contains +!============================================================================ + subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw, version) + +! 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,version) +! + implicit none +! +!input-control for solvers: +! nwaves, nazdir, nstoch, effac, do_physb, kxw +! +! + integer, intent(in) :: me, master, nwaves, nazdir, nstoch + integer, intent(in) :: version + + real(kind=kind_phys), intent(in) :: effac, kxw + logical, intent(in) :: do_physb + +! +!locals +! + real(kind=kind_phys) :: dlzmet + real(kind=kind_phys) :: cstar,rcstar, nslope3, fnorm, zcin + + integer :: inc, jk, jl, iazi +! + real(kind=kind_phys) :: zang, zang1, znorm + real(kind=kind_phys) :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + real(kind=kind_phys) :: fpc, fpc_dc + real(kind=kind_phys) :: 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 = kxw ; 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/v0: init_gw_wmsdis_control ' +! + print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch + print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. + print *, 'ugwp_v1/v0: 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 +! 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 without x=1/c transform +! +! + if (version == 1) then + + 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) + do inc=1, nwav + zdci(inc) = zdx + enddo + + cstar = bnfix/zms + rcstar = 1./cstar + + 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 * + nslope3=nslope+3.0 + do inc=1, nwav + zcin =zci(inc)*rcstar + fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) + 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 + + ENDIF ! if (version == 1) then + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) + + end subroutine initsolv_wmsdis +! +! + end module ugwp_wmsdis_init diff --git a/physics/cires_ugwpv1_module.F90 b/physics/cires_ugwpv1_module.F90 new file mode 100644 index 000000000..eb740c7eb --- /dev/null +++ b/physics/cires_ugwpv1_module.F90 @@ -0,0 +1,557 @@ + +module cires_ugwpv1_module + +! +! 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 machine, only : kind_phys + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + + implicit none + logical :: module_is_initialized + + 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=0 ! control for diag computaions pw wind-temp GW-rms and MF fluxs + logical, parameter :: do_adjoro = .false. + real(kind=kind_phys), parameter :: max_kdis = 450. ! 400 m2/s + real(kind=kind_phys), parameter :: max_axyz = 450.e-5 ! 400 m/s/day + real(kind=kind_phys), parameter :: max_eps = max_kdis*4.e-4 ! max_kdis*BN2 + real(kind=kind_phys), parameter :: maxdudt = max_axyz + real(kind=kind_phys), parameter :: maxdtdt = max_eps*1.e-3 ! max_kdis*BN2/cp + real(kind=kind_phys), parameter :: dked_min = 0.01 + real(kind=kind_phys), parameter :: dked_max = max_kdis +! +! +! Pr = Kv/Kt < 1 for upper layers; Pr_mol = 1./1.95 check it +! + real(kind=kind_phys), parameter :: Pr_kvkt = 1./1. ! kv/kt = 1./3. + real(kind=kind_phys), parameter :: Pr_kdis = Pr_kvkt/(1.+Pr_kvkt) + + real(kind=kind_phys), parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw + real(kind=kind_phys), parameter :: iPr_turb =1./3., iPr_mol =1.95 + + + real(kind=kind_phys), parameter :: hps = hpscale + real(kind=kind_phys), parameter :: hpskm = hps/1000. +! + real(kind=kind_phys), parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 + real(kind=kind_phys), parameter :: khp = 0.287*rhp1 ! R/Cp/Hp + + real(kind=kind_phys), parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model + real(kind=kind_phys), parameter :: linsat = 1.00 + real(kind=kind_phys), parameter :: linsat2 = linsat*linsat + + real(kind=kind_phys), parameter :: ricrit = 0.25 + real(kind=kind_phys), parameter :: frcrit = 0.50 + + + integer :: knob_ugwp_version = 1 + 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(kind=kind_phys), 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 + 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(kind=kind_phys) :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs + real(kind=kind_phys) :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km + real(kind=kind_phys) :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_taumin = 0.25e-3 + real(kind=kind_phys) :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) + real(kind=kind_phys) :: knob_ugwp_lhmet = 200.e3 ! 200 km + logical :: knob_ugwp_tlimb = .true. + character(len=8) :: knob_ugwp_orosolv='pss-1986' + + real(kind=kind_phys) :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes +! +! tune-ups for qbo +! +! real(kind=kind_phys) :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs +! real(kind=kind_phys) :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians +! real(kind=kind_phys) :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing +! real(kind=kind_phys) :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO +! real(kind=kind_phys) :: knob_ugwp_qbotau = 10. ! relaxation time scale in days +! real(kind=kind_phys) :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing +! real(kind=kind_phys) :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing +! 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(kind=kind_phys), parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. +! integer :: nqbo_d1y, nqbo_d2z, nqbo_d3t + + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + real(kind=kind_phys) :: ugwp_effac + +! + 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_tlimb, knob_ugwp_orosolv + +! +! allocatable arrays, initilized during "cires_ugwp_init" & +! released during "cires_ugwp_finalize" +! + real(kind=kind_phys), allocatable :: kvg(:), ktg(:), krad(:), kion(:) + real(kind=kind_phys), allocatable :: zkm(:), pmb(:) + real(kind=kind_phys), allocatable :: rfdis(:), rfdist(:) + integer :: levs_rf + real(kind=kind_phys) :: pa_rf, tau_rf +!........................................................................................... +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +!........................................................................................... + +! integer :: ntau_d1y, ntau_d2t +! real(kind=kind_phys), allocatable :: ugwp_taulat(:) +! real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) +! logical :: flag_alloctau = .false. +! character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' +! +! simple modulation of tau_ngw by the total rain/precip strength +! + real(kind=kind_phys), parameter :: rain_max=8.e-5, rain_lat=41.0, rain_lim=1.e-5 + real(kind=kind_phys), parameter :: w_merra = 1.0, w_nomerra = 1.-w_merra, w_rain =1. + real(kind=kind_phys), parameter :: mtau_rain = 1.e-3, ft_min =0.5, ft_max=2 + real(kind=kind_phys), parameter :: tau_ngw_max = 20.e-3 ! 20 mPa + real(kind=kind_phys), parameter :: tau_ngw_min = .20e-3 ! .2 mPa +! +! Bushell et al. (2015) tau = tau_rainum (~3.8 km) x sqrt(Precip/base_rainum) +! + real(kind=kind_phys), parameter :: tau_rainum = 0.7488e-3 ! 0.74 mPa + real(kind=kind_phys), parameter :: base_rainum = 0.1e-5 ! ~0.1 mm/day + real(kind=kind_phys), parameter :: pbase_um =1./sqrt(base_rainum) * tau_rainum ! + integer, parameter :: metoum_rain = 0 +!================================================================= +! switches that can ba activated for NGW physics include/omit +! +! rotational, non-hydrostatic and eddy-dissipative +! F_coriol F_nonhyd F_kds +!=================================================== + real(kind=kind_phys), parameter :: F_coriol=1.0 ! Coriolis effects + real(kind=kind_phys), parameter :: F_nonhyd=1.0 ! Nonhydrostatic waves + real(kind=kind_phys), parameter :: F_kds =0.0 ! Eddy mixing due to GW-unstable below + + + contains +! +!----------------------------------------------------------------------- +! +! init of cires_ugwp (_init) called from CCPP cap file +! +! --------------------------------------------------------------------------------- +! non-ccpp .... +! +! subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & +! lonr, latr, levs, ak, bk, pref, dtp) +!----------------------------------------------------------------------------------- + + subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, & + errmsg, errflg) +! +! 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_lsatdis_init, only : initsolv_lsatdis + + use ugwp_wmsdis_init, only : initsolv_wmsdis + 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(kind=kind_phys), intent (in) :: ak(levs+1), bk(levs+1), pref + real(kind=kind_phys), intent (in) :: dtp +! +! consider to retire them +! + real(kind=kind_phys), intent (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 :: ios + logical :: exists + + integer :: ncid, iernc, vid, dimid, status + integer :: k + integer :: ddd_ugwp, curday_ugwp +! integer :: version + + +! + 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) +! + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + strsolver= knob_ugwp_orosolv + + 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, *) "CCPP cires_ugwp_namelist_extended_v1" + write (logunit, nml = cires_ugwp_nml) + write (logunit, *) " ================================================================== " + + write (6, *) " ================================================================== " + write (6, *) "CCPP 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 +! +! + kxw = pi2/knob_ugwp_lhmet +! +! +! 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) ) + +! +! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 +! + + do k=1, levs + pmb(k) = ak(k) + pref*bk(k) ! Pa -unit Pref = 1.e5, pmb = Pa + zkm(k) = -hpskm*alog(pmb(k)/pref) + 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 + if (me == master) then + print *, 'cires_ugwpv1 klev_ngw =', launch_level, nint(pmb(launch_level)) + endif +! +! Part-1 :init_global_gwdis again "damn"-con_pi +! call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + me, master) +! +! 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 ) +! +! 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_modv1 ' + 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), & + 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), & + con_pi, lonr, kxw ) + if (me == master) print *, ' init_fjet_gws ' + endif + + if (knob_ugwp_wvspec(2) > 0) then +! conv : con_pi, con_rerth, + call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), & + con_pi, con_rerth, lonr, kxw ) + if (me == master) & + print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + + endif + + ENDIF !IF (do_physb_gwsrcs) + +!====================== +! Part-3 :init_SOLVERS +! ===================== +! +! call init-solvers for "broad" non-stationary multi-wave spectra +! + if (knob_ugwp_solver==1) then +! + kxw = pi2/lhmet + 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, knob_ugwp_version) + + endif + + +!====================== + module_is_initialized = .true. + if (me == master) print *, ' CIRES_ugwpV1 is initialized ', module_is_initialized + + end subroutine cires_ugwpv1_init + + +!============================================= + + subroutine cires_ugwp_advance +!----------------------------------------------------------------------- +! FV3-dycore and CCPP-physics has limited options to +! add "horizontal" gradients of winds and temp-re to +! compute GW-triggers: reserved option if it will be funded ...... +! +! the day-to-day variable sources/spectra and diagnostics for stochastic "triggers" +! +! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields +! and use for stochastic GWP-sources "memory" +! +! this option is not active due to "weak" flexibility +! in communication between "ccpp/gfsphysics" and FV3-dycore +! extension of State%in is needed to pass horizontal gradients +! winds and temperature to compute "spontatneous" GW triggers +!----------------------------------------------------------------------- + implicit none +! +! update GW sources and dissipation +! a) physics-based GW triggers eliminated from cires_ugwpv1_triggers.F90 +! b) stochastic-based spectra and amplitudes is not considered +! c) use "memory" on GW-spectra from previous time-step is not considered +! d) update "background" dissipation of GWs as needed (option for FV3WAM) +! + end subroutine cires_ugwp_advance + +! +! ----------------------------------------------------------------------- +! finalize of cires_ugwp_dealloc +! ----------------------------------------------------------------------- + + + subroutine cires_ugwp_dealloc +! +! 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 +! + if (allocated (kvg)) deallocate (kvg) + if (allocated (ktg)) deallocate (ktg) + if (allocated (krad)) deallocate (krad) + if (allocated (kion)) deallocate (kion) + if (allocated (zkm)) deallocate (zkm) + if (allocated (pmb)) deallocate (pmb) +! if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) +! if (allocated (tau_limb)) deallocate (tau_limb) +! if (allocated (days_limb)) deallocate(days_limb) + + + end subroutine cires_ugwp_dealloc + +! +! + 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 ngwflux_update(me, master, im, levs, kdt, ddd, curdate, & + tau_ddd, xlatd, sinlat,coslat, rain, tau_ngw) + + use machine, only: kind_phys + implicit none +!input + + integer, intent(in) :: me, master !, jdat(8) + integer, intent(in) :: im, levs, kdt + integer, intent(in) :: ddd, curdate + +! integer, intent(in), dimension(im) :: j1_tau, j2_tau +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j2tau, ddy_j1tau + + real(kind=kind_phys), intent(in), dimension(im) :: xlatd, sinlat,coslat + real(kind=kind_phys), intent(in), dimension(im) :: rain, tau_ddd + + real(kind=kind_phys), intent(inout), dimension(im) :: tau_ngw +! +! locals +! + + integer :: i, j1, j2, k, it1, it2, iday + real(kind=kind_phys) :: tem, tx1, tx2, w1, w2, wlat, rw1, rw2 + real(kind=kind_phys) :: tau_rain, flat_rain, tau_3dt + +! + +! code below inside cires_tauamf_data.F90 +! 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_ddd(i) = tx1*w1 + w2*tx2 +! +! add modulattion by the total "rain"-strength Yudin et al.(2020-FV3GFS) and Bushell et al. (2015-UM/METO) +! + do i=1, im + tau_3dt = tau_ngw(i) * w_merra + w_nomerra *tau_ddd(i) + + if (w_rain > 0. .and. rain(i) > 0.) then + + wlat = abs(xlatd(i)) + + if (wlat <= rain_lat .and. rain(i) > rain_lim) then + flat_rain = wlat/rain_lat + rw1 = 0.75 * flat_rain ; rw2 = 1.-rw1 + + tau_rain = tau_3dt * rw1 + rw2 * mtau_rain*min(rain_max, rain(i))/rain_lim + tau_rain = tau_3dt*(1.-w_rain) + w_rain* tau_rain +! +! restict variations from the "tau_ngw" without precip-impact +! +! real, parameter :: ft_min =0.5*tau_g5 < tau_rain < ft_max =2. *tau_g5 +! + if (tau_rain < ft_min *tau_3dt) tau_rain = ft_min *tau_3dt + if (tau_rain > ft_max *tau_3dt) tau_rain = ft_max *tau_3dt + + tau_3dt = tau_rain + + endif + if (metoum_rain == 1) then + tau_rain = min( sqrt(rain(i))*pbase_um, tau_ngw_max) + tau_3dt = max(tau_ngw_min, tau_rain) + endif + endif + tau_ngw(i) = tau_3dt + enddo + + end subroutine ngwflux_update +! + end module cires_ugwpv1_module + diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 new file mode 100644 index 000000000..6913b4c0e --- /dev/null +++ b/physics/cires_ugwpv1_oro.F90 @@ -0,0 +1,1279 @@ +module cires_ugwpv1_oro + +contains + + subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & + grav, con_omega, rd, cpd, rv, pi, arad, fv, & + xlatd, sinlat, coslat, sparea, & + cdmbgwd, hprime, oc, oa4, clx4, theta, sigmad, & + gammad, elvmaxd, sgh30, kpbl, & + u1 ,v1, t1, q1, prsi,del,prsl,prslk, zmeti, zmet, & + pdvdt, pdudt, pdtdt, pkdis, dusfc, dvsfc,rdxzb , & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) + +! call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & +! con_g, con_omega, con_rd, con_cp, con_rv,con_pi, con_rerth, con_fvirt, & +! xlat_d, sinlat, coslat, area, & +! cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & +! sigma, gamma, elvmax, varss, kpbl, & +! ugrs, vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & +! Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & +! zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & +! dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & +! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & +! du_ofdcol, dv_ofdcol, errmsg,errflg ) + +!--------------------------------------------------------------------------- +! ugwp_v1: orogw_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 +! +! 10/2020 main updates +! (a) introduce extra diagnostics of x-y obl-ofd-ogw as in the GSL-drag +! for intercomparisons +! +! (b) quit with cdmbgwd(1:2) +! cdmbgwd(1) = 1 for all resolutions, number of hills control SA-effects +! cdmbgwd(2) = 1 ...............number of hills control SA-effects +! +! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) +! alternative lheff = min( dogw=hprime/sigma*gamma, dx) +! we still not use the "broad spectral solver" +! +! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW +! +! (e) for linsat-solver "eddy" damping Ked = Ked * Nhills, scale-aware +! amplification of the momentum deposition for low-res simulations +!---------------------------------------- + + use machine , only : kind_phys + use ugwp_common, only : dw2min, velmin + + 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_v1, & + n_tofd, ze_tofd, ztop_tofd + + use cires_ugwpv1_module, only : kxw, max_kdis, max_axyz + +! use cires_ugwpv1_sporo, only : oro_spectral_solver + +!---------------------------------------- + implicit none +!---------------------------------------- +! internal parameters +!---------------------------------------- + real(kind=kind_phys), parameter :: sigfac = 3 ! N*hprime height of Subgrid Hill over which SSO-flo + real(kind=kind_phys), parameter :: sigfacs = 0.25 ! M*hprime height is the low boundary of the hill + + real(kind=kind_phys), parameter :: dbmax = 1./3600./12. ! max-Krmtb in hours for u=10 m/s => 20 m/s/day + character(len=8) :: strsolver='pss-1986' ! current operational Ri-solver or 'spect_2020' + + + real(kind=kind_phys) :: gammin = 0.00999999 ! a/b = gammma_min =1% <====> + real(kind=kind_phys), parameter :: nhilmax = 15. ! max number of SSO-hills in grid-box + real(kind=kind_phys), parameter :: sso_min = 3000. ! min-lenghth of the hill, GTOP30 ~dx~1 km + + real(kind=kind_phys), parameter :: nfr = 2.+1. ! power in the emprical Function(Fr/Frc) + real(kind=kind_phys), parameter :: afr = 1. ! (Fr/Frc)^2/(afr +[Fr/Frc]^nfr), Fr = h*mkz + real(kind=kind_phys), parameter :: frnorm =afr+1.0 ! to get cont-ous taulin(Fr=Frc) = tau_nonlin(Fr=Frc) ! + real(kind=kind_phys), parameter :: max_frf =2.0 ! max-value of non-lin flux over the linear at Fr=Frc + + 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), & + 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 + + 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_ogw,dvdt_ogw, dudt_obl,dvdt_obl, dudt_ofd,dvdt_ofd + + real(kind=kind_phys),dimension(im),intent(out) :: dusfc, dvsfc, & + du_ogwcol,dv_ogwcol, du_oblcol,dv_oblcol, du_ofdcol,dv_ofdcol +! + real(kind=kind_phys),dimension(im),intent(out) :: rdxzb + real(kind=kind_phys),dimension(im),intent(out) :: zobl, zogw, zlwb, tau_ogw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +!--------------------------------------------------------------------- +! # 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 vars for SSO +! + + real(kind=kind_phys), dimension(im) :: oa, clx + real(kind=kind_phys), dimension(im) :: sigma, gamma, elvmax ! corrected sigmaD, gammaD, elvmaxD + + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax + + real(kind=kind_phys) :: arhills(im), mkd05_hills(im) ! number of hills in the grid + real(kind=kind_phys) :: taub_kd05(im) +! +! 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) :: ztoph,zlowh,ph_blk, dz_blk + real(kind=kind_phys), dimension(im) :: wk, 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 +!================== +! ogw +!================== + real(kind=kind_phys) :: xlingfs + 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), tausat(im), ahdxres(im) + real(kind=kind_phys) :: heff, hsat, hdis + + integer, dimension(im) :: kref, idxzb, ipt, khtop, iwk, izlow +! +! local real scalars +! + real(kind=kind_phys) :: bnv, fr, ri_gw, brvf, fr2 + 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 + + real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: pi2, pi2h, rdi, gor, grcp, gocp, gr2, bnv2min + + real(kind=kind_phys) :: cleff_max ! resolution-aware max-wn + real(kind=kind_phys) :: nonh_fact ! non-hydroststic factor 1.-(kx/kz_hh)**2 + real(kind=kind_phys) :: fcrit2 + real(kind=kind_phys) :: fr_func, frnd +! +! +! local integers +! + integer :: kmm1, kmm2, lcap, lcapp1 + integer :: npt, kbps + integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll + integer :: k_mtb, k_zlow, ktrial, klevm1 + integer :: i, j, k +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!=========================== +! First step Check do we have sub-grid hills +! +! +! out-arrays are zreoed in unified_ugwp.F90 +! + do i=1,im + rdxzb(i) = 0.0 + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + ipt(i) = 0 + 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 +! ccpp-gwdps.f PARAMETER (hpmax=2400.0, hpmin=1.0) parameter (elvmax > hminmt=50.) + + 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 *, 'orogw_v1 npt = 0 elvmax ', maxval(elvmaxd), hminmt +! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin + + return ! no ogw/mbl calculation done + endif +!=========================== +! scalars from phys-contants added by "CCPP-team" +! by rejecting to use "ugwp_common" +!=========================== + 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 + pi2h = 0.5*pi + rdi = 1.0/rd + gor = grav/rd + grcp = grav*rcpd + gocp = grcp + gr2 = grav*gor + bnv2min = (pi2/1800.)*(pi2/1800.) ! tau_BV_max = 30 min ! +!=========================== +! Start +! +! initialize gamma and sigma +! + gamma(:) = gammad(:) + sigma(:) = sigmad(:) +! +!======================================================================= +! mtb-blocking sigma_min and dxres => cires_initialize (best way ....) +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + +! ! GTOP30-arc dx~1Km res-n so sso_hill ~ (2-4)*dx + cleff_max = pi2/max(dsmin/5.,sso_min) ! maxval for kx = 6.28/(dx_min/5. ~2.5 km) for C768 + cleff_max = pi2/dsmin + + hdxres = 0.5*dsmax + + gammin = min(sso_min/hdxres, 1.) + gammin = max(0.1, gammin) + ! sigma-degined as tan(angle) = h/2: L/2= h/L + sigmin = hpmin/hdxres ! min-slope Hmin= 2*hpmin, dxres=Lmax + + + + if ( kdt == -1 .and. me == master) then + print *, ' orogw_v1 scale2 ', cdmbgwd(2) + print *, ' orogw_v1 imx ', imx + print *, ' orogw_v1 gam_min ', gammin + print *, ' orogw_v1 sso_min ', sso_min + print *, ' orogw_v1 gam_min ', gammin + print *, ' orogw_v1 npt number of GRID-cells with hills ', npt + endif + +!============================================================ +! Purpose to adjust oro-specification on the fly +! needs to be done 1-time during init-n for each block +! hprime sigma gamma and grid-length must be "related" +! width_mount_a = hprime/sigma < dxres cannot access dxres +! width_mount_b = width_mount_a * gamma +! +! Sellipse= pi a*b = (width_mount_a)^2 *gamma <= Sarea +! Limiters on "elongated" hills gamma= a/b < gam_min +! Limiters on "longest" hills (b, a) <= sqrt(area) +! +! 0.01=gammin < gamma=a_hill/b_hill < 1 +! hpmin/(dx/2)=sigmin < sigma= hprime/a_ell < 1. +! Nhills = (dx*dy=Sarea)/(pi* a_hill *b_hill) +!============================================================= + + arhills(:) =0. + mkd05_hills(:) =0. + + do j = 1,npt + i = ipt(j) + dxres = sqrt(sparea(i)) + ahdxres(j) = dxres + if (gamma(i) > 1.0) gamma(i) = 1.0 + + gamma(i) = max(gammin, gamma(i)) +! +! min-adjustment: 1) abs(gamma(i)) ; 2) sigres = max(sigmin, sigma(i)) +! + sigres = max(sigmin, sigma(i)) + sigma(i) =sigres + aelps = min( hprime(i)/sigres, dxres) + belps = min(aelps/abs(gamma(i)), dxres) + gamma(i) = aelps/belps + + if (do_adjoro ) then +! +! more adjustments "lengths", gamma and sigma, valid assuminng H=2*hprime H/2 = hprime +! + if (hprime(i) > hdxres*sigres) sigres= hprime(i)/dxres + aelps = min( hprime(i)/sigres, hdxres) + sigma(i) = sigres + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i), dxres) +! +! small-scale "turbulent" oro-hills < sso_min, sso_min_dx = 3km +! will be treated as "circular" elevations +! + 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) = hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + + endif !aelps < sso_min + endif ! ============== (do_adjoro ) + + selps = belps*belps*gamma(i)*pi ! area of the elliptical hill + + nhills = min(nhilmax, sparea(i)/selps) + arhills(j) = max(nhills, 1.0) + +! 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 + 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) +!======================================================================= +! mtb-blocking : LM-1997; Zadra et al. 2004 ;metoffice dec 2010 H Wells +!======================================================================= + + do i=1,npt + khtop(i) = 2 + idxzb(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) +! +!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) Max-level of SSO-HILL +! + elvmax(j) = min ( sigfac * hprime(j), hncrit) + izlow(i) = 1 ! surface-level + enddo + + +!=================================================================== +! below khtop-level H= 3*hp, and izlow = 0.5*Hp or the "first" layer +! are used tp estimate "Mean" Flow that interact with SG-HILL +! if sig*HP < Hpbl => GWs-> above PBL +! WRF: ( 1 to max(2*Hp or H_pbl) +! GFS-15/16: OGWs (1 to max(Kpbl+1, or K_dPs=(Ps-Pk=50hPa) ~ 950 mb) +! excitation above Kref +! BLOCKING: ZDOMAIN (1 - Kaver => ELVMAX(J) + sigfac * hp) +!=================================================================== + + + 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) +! +! GFSv15/16: izlow=1 +! elvmax(j)=elvmaxd(J) + sig*hp: if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) khtop(i) = max(khtop(i), k+1 ) +! + + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(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 +! +! perform ri_n or ri_mf computation for both OGW and OBL +! + 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 + 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 +! +! place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme +! + enddo + enddo + k = 1 + do i = 1, npt + bnv2(i,k) = bnv2(i,k+1) + enddo +! +! level khtop => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) +! + do i = 1, npt + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == khtop(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(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 +! +! computation of the mean flow char zlow < z < ztop =sigfac*hprime +! + do k = k_zlow, khtop(i)-1 + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + 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 as introduced in LM-97 and ifs +! + ph_blk =0. + do k = khtop(i), 1, -1 + + phiang = atan2(v1(j,k),u1(j,k)) + phiang = theta(j)*rad_to_deg - phiang + + if ( phiang > pi2h ) phiang = phiang - pi + if ( phiang < -pi2h ) phiang = phiang + pi + ang(i,k) = phiang + 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 +! --- LM97 + if ( ph_blk >= fcrit_v1 ) then + idxzb(i) = k + zobl (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif + + endif + enddo +! +! fcrit_v1/fr_flow +! + goto 788 +! +! alternative expression for blocking: +! zobl = max(heff*(1. -fcrit_v1/fr_Flow), 0) +! +! + + 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_v1/fr), 0.0) + zw2 = zmet(j,2) + + if (fr > fcrit_v1 .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 + zobl (j) = zmet(j, k) + endif +788 continue +! +! --- the drag for the blocked flow +! + if ( idxzb(i) > 0 ) then +! +! (4.16)-ifs description +! + 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 +! +! empirical height dep-nt "blocking" length from LM-1997 +! + zlen = sqrt( (zobl(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)) + + 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) +! +! linear damping due to OBL [1/sec]=[U/L_block_orthogonal] +! more accurate along 2-axes of ellipse, here zr-factor is based on Phillips' analytics +! + db(i,k)= dbtmp * uds(i,k) +! if (db(i,k) > dbmax) print *, ' db > dbmax ', 1./db(i,k)/3600., uds(i,k) + db(i,k)= min(db(i,k), dbmax) + enddo +! + endif + enddo +!............................. +!............................. +! end mtn blocking section +!............................. +!............................. +! +!--- OGW 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 +! +! in 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 from the surface + enddo + enddo +! +! iwk - adhoc criteria to select ghe ogw-launch level between +! level ~0.4-0.5 km from surface or/and HPBL-top +! +! in all UGWP-schemes: zogw > zobl +! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb +! the top hill can be inside PBL.... if kref = khtop +! + + kbps = 1 + kmps = km + k_mtb = 1 + + do i=1,npt + j = ipt(i) + k_mtb = max(1, idxzb(i)) + ! WRF/GSL: kogw = max(kpbl, ktop=2*var) + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime + kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime +! +! zogw > zobl +! + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above blocking + 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 +! +! +!====================== we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb +!computation of the mean flow for zobl < z < ztop =sigfac*hprime inb GSL ztop =max(hpbl, ztop) +!===================== + do i = 1,npt + k_mtb = max(1, idxzb(i)) + do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) + 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 parameters (oa), and (clx) [Kim & Arakawa Kim & Doyle] +! + do i = 1,npt + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi ! not sure about "+pi" due to "nwdir"-Kim OA/CLX-processing + 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) ! number of "effective" hills in the grid-box KA-95/KD-05 +! +!GSLdrag ->identical to above +! +! 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(i,mod(nwd-1,4)+1) +! ol(i) = ol4(i,mod(nwd-1,4)+1) +! + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control Logic + + 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 + + do i = 1,npt + velco(i,km) = velco(i,kmm1) + enddo +! +!------------------------------------------------------------------------ +! v0/v1: incorporates modifications for kxridge and heff/hsat +! and employs taulin for fr <=fcrit_v1 +! concept of "clipped" hill if zmtb > 0. is uded to make +! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis +! now it is still used the "single-orowave" along ulow-upwind +! +! in contrast ifs/meto/e-canada employ the 2-orthogonal wave (2otw) schemes of +! it requires "aver angle" and wind projections on axes of ell-hill +! with 2-stresses: taub_a/b as suggested by analytics of Phillips (1984) +!------------------------------------------------------------------------ + + taub(:) = 0. ; taulin(:)= 0. ;taub_kd05 =0. + fcrit2 =fcrit_v1*fcrit_v1 +! +! taub_oro as in KA-95/KD-05 GSL & EMC includes ALL waves (POGWs, Lee-rotors, etc...) +! here taub represents mainly OGWs with nonh_fact = 1. -(kx/kz)**2 +! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered +! + do i = 1,npt + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + + if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac + + if (heff <= 0) cycle + zw1 = ulow(i)/bnv + hsat = fcrit_v1 *zw1 + heff = min(heff, hsat) ! similar hsat-limit in CAM as found in Dec 2020 + + fr = heff/zw1 ! Fr-GSL = Fr * OD -> gamma + + fr = min(fr, frmax) + fr2 = fr*fr + zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) + ! Fr-funct = zw2/(zw2+cg) +! +! [Kim & Doyle, 2005] +! + efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream + efact = min( max(efact,efmin), efmax ) + gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 +! +! !cleff_max(C768 = 6.28/(12.5 km/5.)) ..... +! xlinv(i) = min(coefm * cleff, cleff_max) +! + mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 + + + xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) + + taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) +! +! old: tem = fr2*oc(j) ; gfobnv = gmax * tem / ((tem + cg)*bnv(i)) +! kx =or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge +! + sigres = sigma(j) + inv_b2eff = pi*sigres/heff ! pi2/(2b) + kxridge = pi /ahdxres(i) ! pi2/(2*dx) + xlingfs = max(inv_b2eff, kxridge) +! +! xlinv(i) = max(xlingfs, xlinv(i) ) + + nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 + + if ( nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U +! + taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact + tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact +! +! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => +! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 +! + if ( fr > fcrit_v1 ) then +! + frnd = fr/fcrit_v1 + fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) + taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) + else + taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 + endif + xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 +! + 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 Bn2/U2= kz^2 +! +! diagnostics for zogw, tau_ogw +! + zogw(j) = zmeti(j, kref(i) ) + tau_ogw(j) = taub(i) + +! if (kdt == 1) then +! print *, ' tau =', nint(taub(i)*1.e3), ' tkd05 =', nint(taub_kd05(i)*1.e3), 'Fr=', Fr +! print *, ' zogw=', nint(zogw(j)), ' zobl=', nint(zobl(j)) ! nint(mkd05_hills(i)), nint(arhills(i)) +! endif + + enddo +! +!----set up bottom values of stress +! + do i = 1,npt + taup(i, 1:kref(i) ) = taub(i) + enddo +!====================================================== +! +! Having : taub(i)/tau_ogw(j) => solve for OGW-effects +! +!====================================================== + if (strsolver == 'pss-1986') then + +!====================================================== +! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" +! modified by KD05 with the expression (11):below k=kref ??? +! tau(k+1) = tau(k)*Scorer(K+1)/Scorer(K) +! +! 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 + zw1 = max(velco(i,k), velmin) + temv = 1.0 / zw1 +!=============== +! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB ??? only OA >0 +! k >= kref(i) and .... k+1 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 +! xlinv(i)*0.5 + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 + + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv +! +! rim is the "wave"-richardson number byPalmer,Shutts & Swinbank 1986 , PSS-1986 +! + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check Ri-stability to employ the 'dynamical saturation hypothesis' PSS-1986 +! assuming co-existence of Dyn-Ins and Conv-Ins +! + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = zw1 * (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 ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) + endif ! k >= kref(i)) + enddo ! oro-points + enddo ! do k = kmps, kmm1 vertical level loop +! +! zero momentum deposition at the top model layer: taup(k+1) = taup(k) +! + 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 + zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) +!====================================================================================== +! we estimated "impact" of the single sub-grid hill, we have "arhills" in the grid-box +! 2-estimations of "nhills": 1) geometry-arhills and 2) KDO5 mkd05_hills +! for OBL we used: 1) nhills=Grid_Area/Hill_area +! nhills = max(mkd05_hills(i), arhills(i)) +! Trapped "Lee" downslope wave regimes are not properly modelled: vertical shear +NH/Nonlin +! tau(z) = const => tau(z)/m2(z) = const (empirical mesoscale) +! +! Apply dU/dt-limiter +! +!====================================================================================== +! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hill_area +! apply limiters for OGW tendency +!====================================================================================== + if (abs(zw1) > max_axyz ) then + zw1 = sign(max_axyz, zw1) +! if (kdt <=2 ) then +! print *, ' Hdudt ', nint(max_axyz*1.e5), nint(zw2*1.e5) +! print *, ' Hdudt ', xn(i), yn(i) +! endif + endif + taud(i,k)= zw1 + 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 variations in "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 is performed + + else + +!----------- orogw-solver of wam2017 out : taup, taud, pkdis + + dtfac(:) = 1.0 + + call oro_spectral_solver(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_linsat - linsatdis-solver for stationary OGWs +! +!---- above orogw-solver of wam2017------------ +! +! tofd as in Beljaars-2004 IFS sep-scale ~5km +! CESM ~ 6km (TMS + OGW/OBL) +! sgh30 = varss of GSL (?) +! ---------------------------------------------- + + if( do_tofd ) then +! +! can scale varss(j) by adjusting filterd oro_turb spectra +! a1-coeff by (Lx_flt_cXXX/Lx_c768)^1.9 +! +! klow = 6.28/10km of Beljaars_etal_2004 and kflt^n1 +! kflt = 6.28/18km +! if ( kdt == 1 .and. me == 0) then +! print *, 'ugwp-v1 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 + ! GSL-2/limits a) 250 m ; b) var_maxfd =150m + 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, cpd, dtp, sigflt, zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,km + dudt_ofd(j,k) = utofd1(k) + dvdt_ofd(j,k) = vtofd1(k) +! +! add tofd to gw-tendencies +! + pdvdt(j,k) = pdvdt(j,k) + utofd1(k) + pdudt(j,k) = pdudt(j,k) + vtofd1(k) + pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) + enddo +!2018-diag + du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) + dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) + + dusfc(j) = dusfc(j) + du_ofdcol(j) + dvsfc(j) = dvsfc(j) + dv_ofdcol(j) + enddo + endif ! do_tofd + +!-------------------------------------------- +! combine oro-drag effects MB +TOFD + OGWs + diag-3d +!-------------------------------------------- +! + + 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) + + dudt_obl(j,k) = -dbim * u1(j,k) + dvdt_obl(j,k) = -dbim * v1(j,k) + + pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) + pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) +!2018-diag + du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) + dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) + + dusfc(j) = dusfc(j) + du_oblcol(j) + dvsfc(j) = dvsfc(j) + dv_oblcol(j) + + else +! +! ogw-s above blocking height +! + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) +! + dudt_ogw(j,k) = dtaux + dvdt_ogw(j,k) = dtauy +! + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) + +! + du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) + dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) +! + dusfc(j) = dusfc(j) + du_ogwcol(j) + dvsfc(j) = dvsfc(j) + dv_ogwcol(j) + endif +!============ +! local energy deposition sso-heat due to loss of kinetic energy +!============ + unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) + + 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) + du_ogwcol(j) = -rgrav *du_ogwcol (j) + dv_ogwcol(j) = -rgrav *dv_ogwcol (j) + du_oblcol(j) = -rgrav *du_oblcol (j) + dv_oblcol(j) = -rgrav *dv_oblcol (j) + tau_ogw(j) = -rgrav * tau_ogw(j) + du_ofdcol(j) = -rgrav * du_ofdcol(j) + dv_ofdcol(j) = -rgrav * du_ofdcol(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(zobl), ' 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-v1 ' + print *, maxval(v1), minval(v1), ' v1 gwdps-v1 ' + print *, maxval(t1), minval(t1), ' t1 gwdps-v1 ' + print *, maxval(q1), minval(q1), ' q1 gwdps-v1 ' + print *, maxval(del), minval(del), ' del gwdps-v1 ' + 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), zobl(j)/hprime(j), & + zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) +! + enddo + print * + stop + endif + endif + + return + end subroutine orogw_v1 +! +! + subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + + use machine , only : kind_phys + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! +! adding the implicit tendency estimate +! + implicit none + integer, intent(in) :: levs + real(kind_phys), intent(in) :: con_cp + real(kind_phys), intent(in) :: dtp + + real(kind_phys), intent(in), dimension(levs) :: u, v, zmid + real(kind_phys), intent(in) :: sigflt, zpbl, zsurf + + real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd + + +! +! locals +! + integer :: i, k + real(kind=kind_phys) :: rcpd2, tofd_mag, tofd_zdep + real(kind_phys) :: unew, vnew, eknew + real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer + real(kind=kind_phys), parameter :: tend_imp = 1. + + + real(kind=kind_phys) :: 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 ~1.5 km +! H_efold = max(2*varss, hpbl) +! H_efold = min(H_efold,1500.) + rzdec = 1.0/zdec + + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res + +! GSL-scheme: varmax_fd, beta_fd ,250. +! var_temp = MIN(varss,varmax_fd) + MAX(0., 0.1*(varss-varmax_fd)) +! var_temp = MIN(var_temp, 250.) +! var_temp = var_temp * var_temp +! +! a12=a1* 0.005363 * 0.0759 * 0.00026615161 +! +! rzdec 1./H_efold +! do k=1,levs +! zmet = zmid(k)-zsurf +! wsp=SQRT(u(k)*u(k) + v(k)*v(k)) ! abs(V) +! zarg = zmet*rzdec +! var_temp = var_temp * a12 * exp(-zarg*sqrt(zarg))*zmet**(-1.2) ! this > 0 +! krf = var_temp * wsp /(1. + var_temp*dtp*wsp) +! utofd(k) = -u(k) *krf +! vtofd(k) = -v(k)/(1. + var_temp*krf +! enddo + + 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)) + + tofd_zdep = zmet ** (-1.2) *ztexp + krf = umag * tofd_mag * tofd_zdep + + if (tend_imp == 1.) then + krf = krf/(1.+krf*dtp) + endif + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + if (tend_imp == 1.) then + unew =u(k)+ utofd(k)*dtp ; vnew =v(k)+ vtofd(k)*dtp + eknew =unew*unew + vnew*vnew + epstofd(k) = rcpd2*(ekin-eknew) + else + epstofd(k) = rcpd2*krf*ekin + endif + ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf ! can be used as addition to the mesoscale blocking + enddo +! + end subroutine ugwp_tofd1d + +end module cires_ugwpv1_oro diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 new file mode 100644 index 000000000..ad8f8090d --- /dev/null +++ b/physics/cires_ugwpv1_solv2.F90 @@ -0,0 +1,1045 @@ +module cires_ugwpv1_solv2 + + +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 +!--------------------------------------------------- +! call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & +! tau_ngw, 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, & +! dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + + subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & + tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & + xlatd, sinlat, coslat, & + con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & + pdudt, pdvdt, pdtdt, dked, zngw) +! +!-------------------------------------------------------------------------------- +! 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 +! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out +! -------------------------------------------------------------------------------- +! + use machine, only : kind_phys + + use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt + + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max + + 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, & + gw_eff, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +! + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt + + real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + integer, parameter :: ener_norm =0 + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + + real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(im) + real(kind=kind_phys) ,intent(in) :: coslat(im) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling + real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height +! +! +! +! local =========================================================================================== + + real(kind=kind_phys) :: tauabs(im,levs) ! + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux + real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density + real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind + real(kind=kind_phys) :: vint(levs+1) ! meridional wind + real(kind=kind_phys) :: tint(levs+1) ! temp-re + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + real(kind=kind_phys) :: v_zmet(levs+1) + real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax + + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met + real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti + + real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: Qmid, AKT + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + + integer, dimension(levs) :: Anstab + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + real(kind=kind_phys) :: rdci(nwav), rci(nwav) + real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level + real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level +! +! scalars +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + + + real(kind=kind_phys) :: flux_norm ! norm-factor + real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff +! + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode + real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real(kind=kind_phys) :: ucrit_max + real(kind=kind_phys) :: pwrms, ptrms + real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 + +! + real(kind=kind_phys) :: zdelp, zdelm, taud_min + real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: fmode, expdis, fdis + real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real(kind=kind_phys) :: v_wdi, v_wdpc + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + + real(kind=kind_phys) :: kamp, zmetk, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist + real(kind=kind_phys) :: w1, w2, w3, dtdif + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + real(kind=kind_phys) :: rstar, rstar2 + + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + +!-------------------------------------------------------------------------- +! + nslope3 = nslope + 3.0 + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw +! +! test for input fields +! + 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 + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + suprf(ktop) = kion(levs) + 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) +! + aprsl(1:levs) = prsl(jl,1:levs) +! +! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" +! + do k=1, levs + if (aprsl(k) .lt. psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc= max(ilaunch, 3) + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + +!=====ksrc + + 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) + 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) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch + + + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 +! +! compute diffusion-based arrays km2:levs +! + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1)-azmeti(jk) + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- +! 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) + rhp_wam = zthm*gor +!interface + uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) + vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) + tint(jk) = 0.5 *(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters +! +! 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)) + + + 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 +! +! +! 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), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) + + akt(jk) = gipr/tvc + 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 + + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(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) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi +! +! project winds at ksrc +! + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1:nazd, km2:ktop) =0. + + do inc=1,nwav + + zcin = zci(inc)*rstar + +! +! integrate (flux(cin) x dcin ) old tau-flux and normalization +! + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) +! +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo + + enddo +! +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + + ekin_norm = 1./snorm_ener + +! taub_src = sigu2 * rho_src * [v_kxw / zms ] +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo + +! copy flux-1 into other azimuths +! -------------------------------- + + + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + 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 + +! -------------------------------- + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) =0.0 +! +! wave_dis(iaz, :) = vueff(jk) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) + + 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 + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) 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/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + +! +! rotational cut-off +! + kzw2 = (bn2(jkp)-wdop2)/Cdf2 +! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! + 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_sat = kxw*Cdf1*rhp2/kzw3 +!krad, kvg, kion, ktg + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due 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) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + 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. + w1 =0. + endif +! expdis =1.0 + + fdis = fmode*expdis*wave_act(inc,iaz) +!============================================================================== +! +! Saturated Fluxes and Energy: Spectral and Dicrete Modes +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! +! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) + +! +! +! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) +! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 +! [fden_bn(jkp)] = Pa/dc +! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] + + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] +! +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif +!---------------------------------------------------------------------------- +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +!---------------------------------------------------------------------------- + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if(zdep > 0.0 ) then +! subs on sat-limit + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer + else +! assign dis-ve flux + flux(inc,iaz) = fdis + endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif +! +! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" +! + if ( azmeti(jkp) .ge. zsp_gw) then + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + 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) + exp_sponge = exp(-ze1) +! +! additional sponge +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 +! +! sum for given (jk, iaz) all active "wave" contributions +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (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)* v_cdp *zcinc * vmdiff + + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! +! compute wind and temp-re rms +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + 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 + +! -------------- + enddo ! end Azimuth do-loop + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/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 +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = 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) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(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+1,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 +! +!maxdtdt= dked_max * bnfix2 +! + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo +!---------------------------------------------------------------------------------- +! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur +! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt +! can check "stability" in the column and "add" ktur-estimation +! to suppress instability as needed so dked = dked_gw + ktur_ric +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, nstdif + 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 + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) + + do jk=ksrc,levs + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + +! +! Thermal budget qmid = qheat + qcool +! + do jk=ksrc+1,levs + ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = qmid(jk)*rcpd + dked(jl, jk) = dktur(jk) + enddo +! +! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" +! from the surface/launch-gw to the "top" +! +! +! update by source function X(t+dt) = X(t) + dtp * dXdt +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! +! diagnose turb-profile using "stability-check" relying on the free-atm diffusion +! sc2 = 30m x 30m +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1./ze1 + + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) +! +! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur +! +! update of dked = dked_gw + k_turb_mf +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + +! +! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability +! + if (knob_ugwp_dokdis == 2) then + + do jk=km1,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! +! k instead Jk +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! +! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs +! + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo +! +! compute "smoothed" tendencies by molecular + GW-eddy diffusions +! + do k=ksrc,levs-1 +! +! final updates of tendencies and diffusion +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + 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 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + + enddo ! J-loop +! + RETURN + +!================================= + if (kdt ==1 .and. mpi_id == master) then +! + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: 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_ugwpv1_ngw_solv2 + + +end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 new file mode 100644 index 000000000..98eca419e --- /dev/null +++ b/physics/cires_ugwpv1_sporo.F90 @@ -0,0 +1,353 @@ + + subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & + dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & + grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys +! + implicit none + + integer, intent(in) :: im, levs + integer, intent(in) :: npt + integer, intent(in) :: kdt, me, master + integer, intent(in) :: 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) :: grav, omega, con_rd + + 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 +! +! multiwave oro-spectra +! locals +! + + 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(kind=kind_phys) :: akx(nworo), cxoro(nworo), akx2(nworo) + real(kind=kind_phys) :: aspkx(nworo), c2f2(nworo), cdf2(nworo) + real(kind=kind_phys) :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real(kind=kind_phys) :: tau_kx(nworo),taub_kx(nworo) + + real(kind=kind_phys), dimension(nworo, levs+1) :: wrms, akzw + + real(kind=kind_phys) :: tauz(levs+1), rms_wind(levs+1) + real(kind=kind_phys) :: wave_act(nworo,levs+1) + + real(kind=kind_phys) :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real(kind=kind_phys) :: rayf, kturb + real(kind=kind_phys) :: uz, bv, bv2,kxsp, fcor2, cf2 + + real(kind=kind_phys) :: fdis + real(kind=kind_phys) :: wfdm, wfdt, wfim, wfit + real(kind=kind_phys) :: betadis, betam, betat, kds, cx, rhofac + real(kind=kind_phys) :: etwk, etws, tauk, cx2sat + real(kind=kind_phys) :: cdf1, tau_norm +! +! mean flow +! + real(kind=kind_phys), dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + real(kind=kind_phys) :: belps, aelps, nhills, selps + integer :: i, j, k, isp, iw + 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 + write(6,771) maxval(tau_kx)*maxval(taub)*1.e3, minval(tau_kx), maxval(tau_kx) + endif +771 format( ' oro_spectral_solver ', 3(2x,F8.3)) +! +! 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,:), grav, con_rd, & + & del(j,:), rho(i,:), & + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & + & xn(i), yn(i)) + + fcor2 = (2*omega*sinlat(j))*(2*omega*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) +! +! limiters can be applied to avoid "large" wave accelerations +! +! 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) +! + end subroutine oro_spectral_solver +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & grav, con_rd, & + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + use machine , only : kind_phys + use ugwp_common , only : velmin, dw2min + implicit none + + integer :: nz, nzi + real(kind=kind_phys), dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real(kind=kind_phys), dimension(nz ) :: bn2 ! define at the interfaces + real(kind=kind_phys), dimension(nz+1) :: pint + real(kind=kind_phys) :: xn, yn + real(kind=kind_phys),intent(in) :: grav, con_rd +! output + + real(kind=kind_phys), dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real(kind=kind_phys) :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real(kind=kind_phys) :: zgrow, zmet, rdpm, ritur, kmol, w1 + real(kind=kind_phys) :: rgrav, rdi +! paremeters + real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 + real(kind=kind_phys), parameter :: rhps=1.0/hps + real(kind=kind_phys), parameter :: h4= 0.25/hps + real(kind=kind_phys), parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 + real(kind=kind_phys), 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)) + 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 + diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 new file mode 100644 index 000000000..db95a4f87 --- /dev/null +++ b/physics/cires_ugwpv1_triggers.F90 @@ -0,0 +1,446 @@ +module cires_ugwpv1_triggers + + use machine, only: kind_phys + +contains + + +! +! +! +!>\ingroup cires_ugwp_run +!> @{ +!! +!! + subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) +!================= +! V0: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: 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_v0 +! + + +! + subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) +!================= +! V1: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: 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_2020(im, tau_amp, xlatdeg, tau_gw) +!================================================================= +! modified for FV3GFS-127L/C96 QBO-experiments +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) +!================================================================ + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + real(kind=kind_phys), parameter :: fampqbo = 1.25 ! 1.5 + real(kind=kind_phys), parameter :: famp60S = 1.0 ! 1.5 + real(kind=kind_phys), parameter :: famp60N = 1.0 ! 1.0 + real(kind=kind_phys), parameter :: famp30 = 0.25 ! 0.4 + + real(kind=kind_phys), parameter :: swid15 = 12.5 + real(kind=kind_phys), parameter :: swid60S = 30.0 ! 40 + real(kind=kind_phys), parameter :: swid60N = 25.0 ! 30 + integer :: i +! +! +! + do i=1, im + + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / swid15 + flat_gw = fampqbo * exp(-tem * tem) + if (latdeg <= 3.0) flat_gw = fampqbo + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = famp30 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60N* exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60N + flat_gw = famp60N * exp(- tem * tem) + endif + + if (xlatdeg(i) <= -31.0) then +! + if (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60S * exp(- tem * tem) + endif + if (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60S + flat_gw = famp60S * exp(- tem * tem) + endif + + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_2020 + + + subroutine slat_geos5(im, xlatdeg, tau_gw) + +!================= +! +! WAM: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +! +!================= + implicit none + integer :: im + real(kind=kind_phys) :: xlatdeg(im) + real(kind=kind_phys) :: tau_gw(im) + real(kind=kind_phys) :: latdeg + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys) :: 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(con_pi, naz, xaz, yaz) + implicit none + real(kind=kind_phys) :: con_pi + integer :: naz + real(kind=kind_phys), dimension(naz) :: xaz, yaz + integer :: idir + real(kind=kind_phys) :: phic, drad + real(kind=kind_phys) :: pi2 + pi2 = 2.0*con_pi + 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 +!========================================================================= +! Below subroutine that can be activated after "testing" and extra-work" +!========================================================================= + subroutine emc_modulation(im , levs, ntke, tau_ngw, cdmb3, cdmb4, dtp, & + q_tke, dqdt_tke, del, rain) + + integer, intent(in) :: im , levs, ntke + real(kind=kind_phys), intent(in) :: cdmb3, cdmb4, dtp + real(kind=kind_phys), intent(in) :: rain(im) + real(kind=kind_phys), intent(inout) :: tau_ngw(im) + real(kind=kind_phys), intent(in), dimension(im,levs) :: q_tke, dqdt_tke, del + +! locals + + + real(kind=kind_phys) :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1, tke + + +!============ +! +! below the "EMC-proposal" in May 2019 without rigorous tests reported elsewhere +! can be eliminated due to "lack" of validations and +! in GFSv16 cdmbgwd(3) =1.0 and the next if-loop is "cosmetic" proposal +! +!============ + if (1.0-cdmb3 > 1.0e-6) then + rfac = 86400000. / dtp !??? +! +! in operations cdmbgwd(3) = 1 in GFSv16, and code below is not executed +! + if (cdmb4 > 0.0) then + do i=1,im + turb_fac = 0.0 + if (ntke > 0) then + tem = 0.0 + do k=1,(levs+levs)/3 ! ???? + tke = q_tke(i,k) + dqdt_tke(i,k) * dtp + turb_fac = turb_fac + del(i,k) * tke + tem = tem + del(i,k) + enddo + turb_fac = turb_fac / tem + endif + tx1 = cdmb4*min(10.0, max(turb_fac,rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) * cdmb3 !???? + enddo + endif + endif + end subroutine emc_modulation + + +!=============================================== +! +! Spontaneous GW triggers by dynamical inbalances (OKW, fronts/jets, and convection) +! not activated due to "limited" set of GFS-physics +! statein-type ( needs horizontal gradients of winds and temperature, humodity) +! +!=============================================== + 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(kind=kind_phys), dimension(im, levs) :: dcheat, scheat + real(kind=kind_phys), dimension(im) :: precip, xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real(kind=kind_phys), parameter :: precip_max = 100. ! mm/day + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + + integer :: i, k, klow, ktop, kmid + real(kind=kind_phys) :: 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 +! +! +! + 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(kind=kind_phys), dimension(im, levs) :: trig_fgf +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys), 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(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: 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 ! FV3-127L + 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(kind=kind_phys), dimension(im, levs) :: trig_okw +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch GWs should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 35.e-3 ! 35 mPa + real(kind=kind_phys), parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 ! for FV3-127L + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: 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 + +end module cires_ugwpv1_triggers diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 new file mode 100644 index 000000000..252838ca1 --- /dev/null +++ b/physics/ugwpv1_gsldrag.F90 @@ -0,0 +1,671 @@ +!> \file ugwpv1_gsldrag.F90 +!! This file combines three gravity wave drag schemes under one ("ugwpv1_gsldrag") 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 +!! "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 +!! +!! The ugwpv1_gsldrag scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! NA do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD is not active (NA) +!! NA do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale OGWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale OGWD +!! 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 +!! do_ugwp_v1_w_gsldrag -- activates V1 CIRES UGWP scheme with orographic drag of GSL +!! Note that only one "large-scale" scheme can be activated at a time. +!! + +module ugwpv1_gsldrag + + use machine, only: kind_phys + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 +! use cires_ugwp1_sporo, only: oro_spectral_solver + + use drag_suite, only: drag_suite_run + +! use cires_ugwpv1_triggers, only: get_spectra_tau_convgw, get_spectra_tau_okw, get_spectra_tau_nstgw +! use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 +! use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 +! use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 +! 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 + + implicit none + + private + + public ugwpv1_gsldrag_init, ugwpv1_gsldrag_run, ugwpv1_gsldrag_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the unified UGWP +!> \section arg_table_ugwpv1_gsldrag_init Argument Table +!! \htmlinclude ugwpv1_gsldrag_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine ugwpv1_gsldrag_init ( & + me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & + con_pi, con_rerth, 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, do_ugwp_v1_w_gsldrag, 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(levs+1), bk(levs+1) + real(kind=kind_phys), intent (in) :: dtp + + 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, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only,do_ugwp_v1_w_gsldrag + + 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 +!============================================= +! 3 cases for ORO-schemes + NGWs: +! gwd_opt => "1 and 2, 3, 22, 33' +! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 +! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp +!============================================= + ! 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_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 ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then + print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 + print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only + write(errmsg,'(*(a))') " the CIRES CCPP-suite does not & + support schemes " + errflg = 1 + return + endif + if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then + + print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag + print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only + print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl + write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & + support but has Logic error" + errflg = 1 + return + endif + if (is_initialized) return + + if ( do_ugwp_v1 ) then + call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & + con_p0, dtp, errmsg, errflg) + end if + + if (me == master) then + print *, ' ccpp: ugwpv1_gsldrag_init ' + + print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 + print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl + print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss + print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd + + print *, ' ccpp: ugwpv1_gsldrag_init ' + endif + + is_initialized = .true. + + + end subroutine ugwpv1_gsldrag_init + + +! ----------------------------------------------------------------------- +! finalize of ugwpv1_gsldrag (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP + +!> \section arg_table_ugwpv1_gsldrag_finalize Argument Table +!! \htmlinclude ugwpv1_gsldrag_finalize.html +!! + + subroutine ugwpv1_gsldrag_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_dealloc + + is_initialized = .false. + + end subroutine ugwpv1_gsldrag_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 ugwpv1_gsldrag_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_ugwpv1_gsldrag_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_run.html +!! +!> \section gen_ugwpv1_gsldrag CIRES UGWP Scheme General Algorithm +!! @{ + subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & + gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & + con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & + nmtvr, hprime, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & + rain, br1, hpbl, kpbl, slmsk, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, del, tau_amf, & + dudt_ogw, dvdt_ogw, dtdt_sso, du_ogwcol, dv_ogwcol, & + dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & + dudt_oss, dvdt_oss, du_osscol, dv_osscol, & + dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & + tau_ogw, tau_ngw, tau_oss, & + zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & + lprnt, ipr, errmsg, errflg) + +! old data: jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & +! cap: dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf +! +! +!######################################################################## +! Attention New Arrays and Names must be ADDED inside +! +! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta +! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 +!######################################################################## +![ccpp-table-properties] +! name = GFS_interstitial_type +! type = ddt +!######################################################################## +! +! + implicit none + +! Preference use (im,levs) rather than (:,:) to avoid memory-leaks +! order description control-logical +! other in-variables +! out-variables +! local-variables +! unified diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 +! +! +! interface variables + logical, intent(in) :: ldiag3d, lssav + logical, intent(in) :: flag_for_gwd_generic_tend + logical, intent(in) :: lprnt + + integer, intent(in) :: ipr + +! flags for choosing combination of GW drag schemes to run + + logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd + logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp + logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes + + integer, intent(in) :: me, master, im, levs, ntrac,lonr + real(kind=kind_phys), intent(in) :: dtp, fhzero + integer, intent(in) :: kdt, jdat(8) + +! SSO parameters and variables + integer, intent(in) :: gwd_opt + integer, intent(in) :: nmtvr + real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! in gsl_drag + + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma + + real(kind=kind_phys), intent(in), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx + real(kind=kind_phys), intent(in), dimension(im, 4) :: oa4ss,ol4ss + +!===== +!ccpp-style passing constants +!===== + real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & + con_rv, con_rerth, con_fvirt +! grids + + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + +! State vars + PBL/slmsk +rain + + 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 + integer, intent(in), dimension(im) :: kpbl + + real(kind=kind_phys), intent(in), dimension(im) :: rain + real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk +! +! moved to GFS_phys_time_vary +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau +! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau + real(kind=kind_phys), intent(in), dimension(im) :: tau_amf + +!Output (optional): + + real(kind=kind_phys), intent(out), dimension(im) :: & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol +! +! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) +! du_ngwcol, dv_ngwcol + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: tau_ogw, tau_ngw, tau_oss + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_sso, dtdt_ngw, dtdt_gw + + real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw +! +! + real(kind=kind_phys), intent(inout), dimension(im, levs) :: dudt, dvdt, dtdt + +! +! These arrays are only allocated if ldiag=.true. +! +! Version of COORDE updated by CCPP-dev for time-aver +! + real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw + + + + real(kind=kind_phys), intent(out), dimension(im) :: rdxzb ! for stoch phys. mtb-level + + 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 +!------------ +! +! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init +! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa +! +! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 +!------------ +! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 + +! switches that activate impact of OGWs and NGWs + +! integer :: nmtvr_temp + + 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 + +! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 +! diagnostics for wind and temp rms to compare with space-borne data and metrics +! in the Middle atmosphere: 20-110 km ( not active in CCPP-style, oct 2020) +! 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 +! ------------------ +! +! for all oro-suites can uze geo-meters having "hpbl" +! + inv_g = 1./con_g +! +! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust +! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" +! + zmeti = phii*inv_g + zmet = phil*inv_g + +!=============================================================== +! ORO-diag + + dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. + dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. + + dusfcg (:) = 0. ; dvsfcg(:) =0. + + du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. + du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. + +! + dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. + +! ngw+ogw - diag + + dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. +! source fluxes + + tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. + +! launch layers + + zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. +!=============================================================== +! Accumulated tendencies due to 3-SSO schemes (all ORO-physics) +! ogw + obl +oss +ofd ..... no explicit "lee wave trapping" +!=============================================================== + 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 +! +! ------------------ +! +! Also zero all ORO diag-c arrays to avoid "special ifs and zeros" +! like old GFS-ORO gwdps_run has limited diagnostics +! +! ------------------ + + ! 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 & + .or. do_ugwp_v1_w_gsldrag) then +! +! the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : +! +! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd +! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol +! dusfcg, dvsfcg +! gsd_diss_ht_opt =0 => Pdtdt = bl+ls +(Pdtdt=0) +! + call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & + 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, & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd, & + dusfcg, dvsfcg, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol, & + slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & + con_fvirt,con_pi,lonr, & + 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) +! +! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol +! + if (kdt <= 2 .and. me == master) then + print *, ' unified drag_suite_run ', kdt + print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 + print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 + +! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 + +! if (gwd_opt == 22 .or. gwd_opt == 33) then +! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 +! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 +! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 +! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 +! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 +! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 +! endif + endif + + else +! +! not gsldrag scheme for example "do_ugwp_v1_orog_only" +! + + if ( do_ugwp_v1_orog_only ) then +! +! for TOFD we use now "varss" of GSL-drag /not sgh30=abs(oro-oro_f)/ +! only sum of integrated ORO+GW effects (dusfcg and dvsfcg) = sum(ogw + obl + oss*0 + ofd + ngw) +! +! OROGW_V1 introduce "orchestration" between OGW-effects and Mountain Blocking +! it starts to examines options for the Scale-Aware (SA)formulation of SSO-effects +! if ( me == master .and. kdt == 1) print *, ' bf orogw_v1 nmtvr=', nmtvr, ' do_tofd=', do_tofd + + if (gwd_opt ==1 )sgh30 = 0.15*hprime ! portion of the mesoscale SSO (~[oro_unfilt -oro_filt) + if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run + + call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & + con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & + con_rerth, con_fvirt,xlat_d, sinlat, coslat, area, & + cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & + sigma, gamma, elvmax, sgh30, kpbl, ugrs, & + vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & + Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) +! +! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms +! +! + if (kdt <= 2 .and. me == master) then + + print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr + print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 + print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 + print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 + print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 + print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 + endif + +! pdudt = 0.0*pdudt ; pdvdt = 0.0*pdvdt ; pdtdt = 0. + + end if +! +! GFS-style diag dt3dt(:.:, 1:14) +! + 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 + ENDIF ! +! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Begin non-stationary GW schemes +! ugwp_v1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (do_ugwp_v1) then + +!================================================================== +! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) +! +! updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs +!================================================================== + + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) +! if (me == master) then +! print *, ' ugwpv1 forcing ', maxval(tau_ngw), minval(tau_ngw) +! print *, ' ugwpv1 forcing tamp_mpa ', tamp_mpa +! endif + 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.) + + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp +! + call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & + tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) + + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & + tau_ngw, 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, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + + + if (me == master .and. kdt <= 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' +! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + + print *, ' ugwp_v1 ', kdt + print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 + print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 + print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 + + + endif + + + end if ! do_ugwp_v1 + +! +! GFS-style diag dt3dt(:.:, 1:14) time-averaged +! + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtp + ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtp + ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtp + enddo + enddo + endif + +! +! get total sso-OGW + NGW +! + dudt_gw = Pdudt +dudt_ngw + dvdt_gw = Pdvdt +dvdt_ngw + dtdt_gw = Pdtdt +dtdt_ngw + kdis_gw = Pkdis +kdis_ngw +! +! add to previous phys-tendencies +! ?-accumulation of GFS ( pbl + gw =0 rf should be taken out from physics, inside FV3-dycore) + + dudt = dudt + dudt_ngw + dvdt = dvdt + dvdt_ngw + dtdt = dtdt + dtdt_ngw + + end subroutine ugwpv1_gsldrag_run +!! @} +!>@} +end module ugwpv1_gsldrag diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta new file mode 100644 index 000000000..73d717f78 --- /dev/null +++ b/physics/ugwpv1_gsldrag.meta @@ -0,0 +1,1265 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag + type = scheme + dependencies = machine.F,drag_suite.F90 + dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 + dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_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 +[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 + 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 +[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 +[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 +[do_ugwp_v1_w_gsldrag] + standard_name = do_ugwp_v1_w_gsldrag + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + 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 = ugwpv1_gsldrag_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 = ugwpv1_gsldrag_run + 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 +[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 +[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 +[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 + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + 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_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 +[do_ugwp_v1_w_gsldrag] + standard_name = do_ugwp_v1_w_gsldrag + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + 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 +[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 +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + 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_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 + 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_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) + units = none + dimensions = () + 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 +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + type = real + kind = kind_phys + intent = in + 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_loop_extent,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_loop_extent,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_loop_extent) + 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_loop_extent) + 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_loop_extent,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 sso higher than critical height small scale + units = frac + dimensions = (horizontal_loop_extent,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_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + 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_loop_extent) + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_amf] + standard_name = ngw_abs_momentum_flux + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + 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 = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ogw] + standard_name = y_momentum_tendency_from_meso_scale_ogw + long_name = y momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_sso] + standard_name = tendency_of_air_temperature_due_to_sso + long_name = air temperature tendency due to subgrid-scale orography + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ogwcol] + standard_name = integrated_x_momentum_flux_from_meso_scale_ogw + long_name = integrated x momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ogwcol] + standard_name = integrated_y_momentum_flux_from_meso_scale_ogw + long_name = integrated y momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_obl] + standard_name = x_momentum_tendency_from_blocking_drag_vy + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_obl] + standard_name = y_momentum_tendency_from_blocking_drag_vy + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_oblcol] + standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_oblcol] + standard_name = integrated_y_momentum_flux_from_blocking_drag_vy + long_name = integrated y momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_oss] + standard_name = x_momentum_tendency_from_small_scale_gwd_vy + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_oss] + standard_name = y_momentum_tendency_from_small_scale_gwd_vy + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_osscol] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd_vy + long_name = integrated x momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_osscol] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd_vy + long_name = integrated y momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ofd] + standard_name = x_momentum_tendency_from_form_drag_vy + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ofd] + standard_name = y_momentum_tendency_from_form_drag_vy + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ofdcol] + standard_name = integrated_x_momentum_flux_from_form_drag_vy + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ofdcol] + standard_name = integrated_y_momentum_flux_from_form_drag_vy + long_name = integrated y momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ngw] + standard_name = tendency_of_x_wind_due_to_ngw + long_name = zonal wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ngw] + standard_name = tendency_of_y_wind_due_to_ngw + long_name = meridional wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_ngw] + standard_name = tendency_of_air_temperature_due_to_ngw + long_name = air temperature tendency due to non-stationary GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_ngw] + standard_name = eddy_mixing_due_to_ngw + long_name = eddy mixing due to non-stationary GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_allgw + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_allgw + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_allgw + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_gw] + standard_name = eddy_mixing_due_to_allgw + long_name = eddy mixing due to all GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_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_loop_extent) + 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_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_oss] + standard_name = instantaneous_momentum_flux_due_to_sso + long_name = momentum flux or stress due to SSO including OBL-OSS-OFD + units = Pa + dimensions = (horizontal_loop_extent) + 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 waves + units = m + dimensions = (horizontal_loop_extent) + 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 for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zobl] + standard_name = height_of_mountain_blocking_v1 + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zngw] + standard_name = height_of_launch_level_of_nonsta_gravity_wave + long_name = height of launch level of non-stationary GWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + 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_loop_extent) + 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_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F + intent = out + 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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent) + type = real + kind = kind_phys + intent = out + 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_loop_extent,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_loop_extent,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_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldu3dt_ngw] + 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_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ngw] + 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_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ngw] + 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_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + 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 +[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/ugwpv1_gsldrag_post.F90 b/physics/ugwpv1_gsldrag_post.F90 new file mode 100644 index 000000000..1d8813f65 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.F90 @@ -0,0 +1,107 @@ +!> \file ugwpv1_gsldrag_post.F90 +!! This file contains +module ugwpv1_gsldrag_post + +contains + +!>\defgroup ugwpv1_gsldrag_post ugwpv1_gsldrag Scheme Post +!! @{ + + subroutine ugwpv1_gsldrag_post_init () + end subroutine ugwpv1_gsldrag_post_init + +!>@brief The subroutine initializes the unified UGWP + +!> \section arg_table_ugwpv1_gsldrag_post_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_post_run.html +!! + + + + subroutine ugwpv1_gsldrag_post_run ( im, levs, & + ldiag_ugwp, dtf, & + dudt_gw, dvdt_gw, dtdt_gw, du_ofdcol, du_oblcol, tau_ogw, & + tau_ngw, zobl, zlwb, zogw, dudt_obl, dudt_ofd, dudt_ogw, & + 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(im) :: zobl, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(im) :: du_ofdcol, tau_ogw, du_oblcol, tau_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw + + real(kind=kind_phys), intent(in), dimension(im,levs) :: dtdt_gw, dudt_gw, dvdt_gw + real(kind=kind_phys), intent(in), dimension(im,levs) :: dudt_obl, dudt_ogw, dudt_ofd + real(kind=kind_phys), intent(inout), dimension(im,levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + + real(kind=kind_phys), intent(inout), dimension(im,levs) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +! post creates the "time-averaged" diagnostics" +! + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zobl + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *du_ofdcol + tot_mtb = tot_mtb + dtf *du_oblcol + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_obl + du3dt_tms = du3dt_tms + dtf *dudt_ofd + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *dudt_gw + dv3dt_ngw = dv3dt_ngw + dtf *dvdt_gw + endif + +!===================================================================== +! Updates inside the ugwpv1_gsldrag.F90 +! +! dtdt = dtdt + dtdt_gw +! dudt = dudt + dudt_gw +! dvdt = dvdt + dvdt_gw +! +! "post" may also create the "time-averaged" diagnostics" +! +! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then +! do k=1,levs +! do i=1,im +! ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtf +! ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtf +! ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtf +! +! ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + dudt_ogw(i,k)*dtf +! ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + dvdt_ogw(i,k)*dtf +! ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + dtdt_ogw(i,k)*dtf +! enddo +! enddo +! endif +! +!===================================================================== + end subroutine ugwpv1_gsldrag_post_run + + subroutine ugwpv1_gsldrag_post_finalize () + end subroutine ugwpv1_gsldrag_post_finalize + +!! @} +end module ugwpv1_gsldrag_post diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta new file mode 100644 index 000000000..9ed76d6e8 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.meta @@ -0,0 +1,321 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_run + type = scheme +[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 +[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 +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_allgw + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_allgw + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_allgw + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[du_oblcol] + standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[du_ofdcol] + standard_name = integrated_x_momentum_flux_from_form_drag_vy + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + 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_loop_extent) + 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_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zobl] + standard_name = height_of_mountain_blocking_v1 + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + 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 for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[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_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_obl] + standard_name = x_momentum_tendency_from_blocking_drag_vy + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ofd] + standard_name = x_momentum_tendency_from_form_drag_vy + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,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 = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent) + 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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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_loop_extent,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 = ugwpv1_gsldrag_post_finalize + type = scheme + diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 5c0604f86..220acb42c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -244,8 +244,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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,dx - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss, dx + +!vay-nov 2020 + real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + 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 @@ -315,12 +318,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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 + integer :: nmtvr_temp real(kind=kind_phys), dimension(:,:), allocatable :: tke @@ -331,23 +333,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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 @@ -388,7 +373,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, sgh30 = abs(oro - oro_uf) ! w/o orographic effects else - sgh30 = 0. + sgh30 = varss endif inv_g = 1./con_g @@ -543,26 +528,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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 @@ -577,160 +542,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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, & - 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) - - 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 !! @} !>@} From 9ebf28b79f34517647d63d63acfda5dd9ba47441 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Mon, 11 Jan 2021 03:24:22 -0500 Subject: [PATCH 03/16] physics/cires_tauamf_data.F90 ugwp-data --- physics/cires_tauamf_data.F90 | 256 ++++++++++++++++++++++++++++++++++ 1 file changed, 256 insertions(+) create mode 100644 physics/cires_tauamf_data.F90 diff --git a/physics/cires_tauamf_data.F90 b/physics/cires_tauamf_data.F90 new file mode 100644 index 000000000..5a0296d4c --- /dev/null +++ b/physics/cires_tauamf_data.F90 @@ -0,0 +1,256 @@ +module cires_tauamf_data + + use machine, only: kind_phys +!........................................................................................... +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +!........................................................................................... +implicit none + + integer :: ntau_d1y, ntau_d2t + real(kind=kind_phys), allocatable :: ugwp_taulat(:) + real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) + logical :: flag_alloctau = .false. + character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' + + public :: read_tau_amf, cires_indx_ugwp, tau_amf_interp + +contains + + subroutine read_tau_amf(me, master, errmsg, errflg) + + use netcdf + integer, intent(in) :: me, master + integer :: ncid, iernc, vid, dimid, status + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! Tabulated sources +! + + iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) + + if(iernc.ne.0) then + write(errmsg,'(*(a))') "read_tau_amf: cannot open file_limb_tab data-file ", & + trim(ugwp_taufile) + print *, 'cannot open ugwp-v1 tau-file=',trim(ugwp_taufile) + errflg = 1 + return + 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 of tau_ngw ugwp-v1 ' + if (ntau_d2t .le. 0 .or. ntau_d1y .le. 0) then + print *, 'ugwp-v1 tau-file=', trim(ugwp_taufile) + print *, ' ugwp-v1: ', 'ntau_d2t=',ntau_d2t, 'ntau_d2t=',ntau_d1y + stop + endif + + if (.not.allocated(ugwp_taulat)) allocate (ugwp_taulat(ntau_d1y )) + if (.not.allocated(days_limb)) allocate (days_limb(ntau_d2t)) + if (.not.allocated(tau_limb)) 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 + + end subroutine read_tau_amf + + subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau) + + use machine, only: kind_phys + + implicit none +! +! + integer, intent(in) :: npts, me, master + real(kind=kind_phys) , dimension(npts), intent(in) :: dlat + + integer, dimension(npts), intent(inout) :: j1_tau, j2_tau + real(kind=kind_phys) , dimension(npts), intent(inout) :: w1_j1tau, w2_j2tau + +!locals + + integer :: i,j, j1, j2 + + + +! +! weights for tau_limb w1_j1tau, w2_j2tau +! + + + if (me == master) then + print * + print *, ' ugwp_tabulated files input ' +! print *, ' ugwp_taulat ', ugwp_taulat +! print *, ' days ', days_limb + print *, ' TAU-ugwp ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 + print * + endif +! + 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 + + return + + if (me == master ) then + +223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) + print *, 'ugwp-v1 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 * + + endif + end subroutine cires_indx_ugwp + + subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) + + use machine, only: kind_phys + implicit none + +!input + integer, intent(in) :: me, master + integer, intent(in) :: im, idate(4) + real(kind=kind_phys), intent(in) :: fhour + + real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1, ddy_j2 + integer , intent(in), dimension(im) :: j1_tau,j2_tau +!ouput + real(kind=kind_phys), dimension(im) :: tau_ddd +!locals + + integer :: i, j1, j2, it1, it2 , iday + integer :: ddd + real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd +! +! define day of year ddd ..... from the old-fashioned "GFS-style" +! having idate[4] ??? +! + call gfs_idate_calendar(idate, fhour, ddd, fddd) + + it1 = 2 + do iday=1, ntau_d2t + if (fddd .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 *, ' Error in time-interpolation for tau_amf_interp ' + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + print *, ' Error in time-interpolation see cires_tauamf_data.F90 ' + stop + endif + + w2 = (fddd-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_j1(i)+tau_limb(j2, it1)*ddy_j2(i) + tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) + tau_ddd(i) = tx1*w1 + w2*tx2 + enddo + +! if(me == master) then +! print *, ' tau_amf_interp : ', fddd, ddd , ' DOY ' +! print *, ' tau_amf_maxmin : ' , maxval(tau_ddd)*1.e3, minval(tau_ddd)*1.e3 +! endif + + end subroutine tau_amf_interp + + subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) + + use machine, only: kind_phys + implicit none +! input + integer, intent(in) :: idate(4) + real(kind=kind_phys), intent(in) :: fhour +!out + integer, intent(out) :: ddd + real(kind=kind_phys), intent(out) :: fddd +! +!locals +! + real(kind=kind_phys) :: rinc(5), rjday + integer :: jdow, jdoy, jday + real(4) :: rinc4(5) + integer :: w3kindreal, w3kindint + + integer :: iw3jdn + integer :: jd1, jddd + + integer idat(8),jdat(8) + + + idat(1:8) = 0 + idat(1) = idate(4) + idat(2) = idate(2) + idat(3) = idate(3) + idat(5) = idate(1) + rinc(1:5) = 0. + rinc(2) = fhour +! get jdat + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4 = rinc + call w3movdat(rinc4, idat,jdat) + else + call w3movdat(rinc, idat,jdat) + endif + +!! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow, ddd, jday) + fddd = float(ddd) + jdat(5) / 24. + + end subroutine gfs_idate_calendar + +end module cires_tauamf_data From e7cd3069417df6e9b51cca1a38e5c6ab3aeccceb Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Sun, 17 Jan 2021 01:38:41 +0000 Subject: [PATCH 04/16] Added new logical flag do_ugwp_v0_nst_only which allows non-stationary drag from ugwp_v0 to be run with GSL drag suite --- physics/unified_ugwp.F90 | 47 ++++++++++++++++++++++++++++----------- physics/unified_ugwp.meta | 24 ++++++++++++++++++++ 2 files changed, 58 insertions(+), 13 deletions(-) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 5c0604f86..a07e85202 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -25,6 +25,7 @@ !! 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_ugwp_v0_nst_only -- activates V0 CIRES UGWP scheme - non-stationary 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 @@ -75,9 +76,9 @@ 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, & 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) + do_ugwp_v0, do_ugwp_v0_orog_only, do_ugwp_v0_nst_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 @@ -98,6 +99,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & 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_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only @@ -136,11 +138,23 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & end if + ! Test to make sure that if ugwp_v0 non-stationary-only is selected that + ! ugwp_v1 is not also selected + if ( do_ugwp_v0_nst_only .and. (do_ugwp_v1.or.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: do_ugwp_v0_nst_only can only be & + &selected if both do_ugwp_v1 and do_ugwp_v1_orog_only are not & + &selected" + errflg = 1 + return + + end if + if (is_initialized) return - if ( do_ugwp_v0 ) then + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) 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, & @@ -148,7 +162,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & 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" + &do_ugwp_v0 or do_ugwp_v0_nst_only is true and cdmbgwd(3) <= 0" errflg = 1 return end if @@ -177,11 +191,13 @@ end subroutine unified_ugwp_init !! \htmlinclude unified_ugwp_finalize.html !! - subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & + do_ugwp_v1,errmsg, errflg) implicit none ! - logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only, & + do_ugwp_v1 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -191,7 +207,7 @@ subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) if (.not.is_initialized) return - if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwp_mod_finalize() if ( do_ugwp_v1 ) call cires_ugwp_finalize() @@ -234,8 +250,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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, & - do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + do_ugwp_v1, do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) implicit none @@ -303,6 +319,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! flags for choosing combination of GW drag schemes to run logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only @@ -408,7 +425,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, end if - if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only.or.do_ugwp_v0_nst_only ) then do k=1,levs do i=1,im @@ -419,6 +436,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo enddo + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary @@ -466,7 +487,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! ! ugwp_v0 non-stationary GW drag ! - if (do_ugwp_v0) then + if (do_ugwp_v0.or.do_ugwp_v0_nst_only) then if (cdmbgwd(3) > 0.0) then @@ -574,7 +595,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif - end if ! do_ugwp_v0 + end if ! do_ugwp_v0.or.do_ugwp_v0_nst_only ! diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 675a68edd..f60bdc038 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -207,6 +207,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary 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 @@ -277,6 +285,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + 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 @@ -1293,6 +1309,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary 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 From 8463f3ad8fa38cf0b944fcd8a48194b75f0e8222 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Wed, 20 Jan 2021 13:42:28 -0500 Subject: [PATCH 05/16] new GFS_phys_time_vary.fv3.F90; and new ugwp_common instead physcons --- physics/GFS_phys_time_vary.fv3.F90 | 50 +- physics/GFS_phys_time_vary.fv3.meta | 95 ++- physics/cires_tauamf_data.F90 | 63 +- physics/cires_ugwpv1_initialize.F90 | 253 ++++--- physics/cires_ugwpv1_module.F90 | 74 +- physics/cires_ugwpv1_oro.F90 | 1017 +++++++++++---------------- physics/cires_ugwpv1_solv2.F90 | 64 +- physics/cires_ugwpv1_sporo.F90 | 56 +- physics/cires_ugwpv1_triggers.F90 | 82 +-- physics/ugwpv1_gsldrag.F90 | 274 +++++--- physics/ugwpv1_gsldrag.meta | 128 ++-- 11 files changed, 1004 insertions(+), 1152 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 8f0bc50d9..04f191fdf 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -28,6 +28,9 @@ module GFS_phys_time_vary use iccninterp, only : read_cidata, setindxci, ciinterpol use gcycle_mod, only : gcycle + + use cires_tauamf_data, only: cires_indx_ugwp, read_tau_amf, tau_amf_interp + use cires_tauamf_data, only: tau_limb, days_limb, ugwp_taulat #if 0 !--- variables needed for calculating 'sncovr' @@ -58,6 +61,7 @@ subroutine GFS_phys_time_vary_init ( jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & nthrds, errmsg, errflg) implicit none @@ -77,6 +81,10 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) + + logical, intent(in) :: do_ugwp_v1 + real(kind_phys), intent(inout) :: ddy_j1tau(:), ddy_j2tau(:) + integer, intent(inout) :: jindx1_tau(:), jindx2_tau(:) integer, intent(in) :: nthrds character(len=*), intent(out) :: errmsg @@ -100,6 +108,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & +!$OMP shared (do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau) & !$OMP private (ix,i,j) !$OMP sections @@ -176,7 +185,11 @@ subroutine GFS_phys_time_vary_init ( ! No consistency check needed for in/ccn data, all values are ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif - +!$OMP section +!> - Call tau_amf dats for ugwp_v1 + if (do_ugwp_v1) then + call read_tau_amf(me, master, errmsg, errflg) + endif !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") @@ -211,7 +224,12 @@ subroutine GFS_phys_time_vary_init ( jindx2_ci, ddy_ci, xlon_d, & iindx1_ci, iindx2_ci, ddx_ci) endif - +!$OMP section +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs + if (do_ugwp_v1) then + call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau) + endif !$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 @@ -273,7 +291,8 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, errmsg, errflg) + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -297,11 +316,19 @@ subroutine GFS_phys_time_vary_timestep_init ( real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 real(kind_phys), intent(inout) :: rann(:,:) + + logical, intent(in) :: do_ugwp_v1 + integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) + real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) + real(kind_phys), intent(inout) :: tau_amf(:) + ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) + logical, intent(in) :: use_ufo, nst_anl, frac_grid + real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & @@ -310,7 +337,7 @@ subroutine GFS_phys_time_vary_timestep_init ( facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & - snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -404,7 +431,13 @@ subroutine GFS_phys_time_vary_timestep_init ( iindx2_ci, ddx_ci, & levs, prsl, in_nm, ccn_nm) endif - + +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that resolve GW-activ + if (do_ugwp_v1) then + call tau_amf_interp(me, master, im, idate,fhour, & + jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf) + endif + !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN @@ -479,7 +512,12 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (allocated(ciplin) ) deallocate(ciplin) if (allocated(ccnin) ) deallocate(ccnin) if (allocated(ci_pres) ) deallocate(ci_pres) - + + ! Deallocate UGWP-input arrays + if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) + if (allocated (tau_limb)) deallocate (tau_limb) + if (allocated (days_limb)) deallocate(days_limb) + is_initialized = .false. end subroutine GFS_phys_time_vary_finalize diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 7ae6b4948..e20920686 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F + dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] @@ -315,6 +315,48 @@ type = integer 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 +[jindx1_tau] + standard_name = index_interp_weight1_taungw + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[jindx2_tau] + standard_name = index_interp_weight2_taungw + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[ddy_j1tau] + standard_name = interp_weight1_taungw + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = interp_weight2_taungw + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1335,6 +1377,57 @@ kind = kind_phys intent = inout 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 +[jindx1_tau] + standard_name = index_interp_weight1_taungw + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[jindx2_tau] + standard_name = index_interp_weight2_taungw + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[ddy_j1tau] + standard_name = interp_weight1_taungw + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = interp_weight2_taungw + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[tau_amf] + standard_name = ngw_abs_momentum_flux + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_tauamf_data.F90 b/physics/cires_tauamf_data.F90 index 5a0296d4c..e0d43e74e 100644 --- a/physics/cires_tauamf_data.F90 +++ b/physics/cires_tauamf_data.F90 @@ -2,7 +2,7 @@ module cires_tauamf_data use machine, only: kind_phys !........................................................................................... -! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run !........................................................................................... implicit none @@ -25,7 +25,6 @@ subroutine read_tau_amf(me, master, errmsg, errflg) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg -! Tabulated sources ! iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) @@ -76,8 +75,7 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j use machine, only: kind_phys implicit none -! -! + integer, intent(in) :: npts, me, master real(kind=kind_phys) , dimension(npts), intent(in) :: dlat @@ -86,23 +84,7 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j !locals - integer :: i,j, j1, j2 - - - -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - - - if (me == master) then - print * - print *, ' ugwp_tabulated files input ' -! print *, ' ugwp_taulat ', ugwp_taulat -! print *, ' days ', days_limb - print *, ' TAU-ugwp ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 - print * - endif + integer :: i,j, j1, j2 ! do j=1,npts j2_tau(j) = ntau_d1y @@ -119,33 +101,16 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j 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))) - + / (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 - return - - if (me == master ) then - -223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) - print *, 'ugwp-v1 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 * - - endif end subroutine cires_indx_ugwp - subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) - + subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) use machine, only: kind_phys implicit none @@ -165,7 +130,6 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd ! ! define day of year ddd ..... from the old-fashioned "GFS-style" -! having idate[4] ??? ! call gfs_idate_calendar(idate, fhour, ddd, fddd) @@ -196,12 +160,7 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) tau_ddd(i) = tx1*w1 + w2*tx2 enddo - -! if(me == master) then -! print *, ' tau_amf_interp : ', fddd, ddd , ' DOY ' -! print *, ' tau_amf_maxmin : ' , maxval(tau_ddd)*1.e3, minval(tau_ddd)*1.e3 -! endif - + end subroutine tau_amf_interp subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) @@ -235,22 +194,20 @@ subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) idat(5) = idate(1) rinc(1:5) = 0. rinc(2) = fhour -! get jdat +! call w3kind(w3kindreal,w3kindint) if(w3kindreal==4) then rinc4 = rinc call w3movdat(rinc4, idat,jdat) else call w3movdat(rinc, idat,jdat) - endif - -!! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) + endif +! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) jdow = 0 jdoy = 0 jday = 0 call w3doxdat(jdat,jdow, ddd, jday) - fddd = float(ddd) + jdat(5) / 24. - + fddd = float(ddd) + jdat(5) / 24. end subroutine gfs_idate_calendar end module cires_tauamf_data diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/cires_ugwpv1_initialize.F90 index 1050da194..ad39def17 100644 --- a/physics/cires_ugwpv1_initialize.F90 +++ b/physics/cires_ugwpv1_initialize.F90 @@ -13,41 +13,83 @@ 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(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. - real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 - real(kind=kind_phys), parameter :: grav2 = grav + grav - real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real(kind=kind_phys) :: pi, pi2, pih, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: arad, p0s + real(kind=kind_phys) :: grav, grav2, rgrav, rgrav2 + real(kind=kind_phys) :: cpd, rd, rv, fv + real(kind=kind_phys) :: rdi, rcpd, rcpd2 + + real(kind=kind_phys) :: gor, gr2, grcp, gocp, rcpdl, grav2cpd + real(kind=kind_phys) :: bnv2min, bnv2max + real(kind=kind_phys) :: dw2min, velmin, minvel + real(kind=kind_phys) :: omega1, omega2, omega3 + real(kind=kind_phys) :: hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm + real(kind=kind_phys) :: mkzmin, mkz2min, mkzmax, mkz2max, cdmin + real(kind=kind_phys) :: rcpdt - real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 - real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd - real(kind=kind_phys), parameter :: gor = grav/rd - real(kind=kind_phys), parameter :: gr2 = grav*gor - real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp - real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - - real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi - real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 - - real(kind=kind_phys), parameter :: arad = 6370.e3 +! real(kind=kind_phys), parameter :: grav2 = grav + grav +! real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav +! real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd +! real(kind=kind_phys), parameter :: gor = grav/rd, rcpdt = 1./(cp*dtp) + +! real(kind=kind_phys), parameter :: gr2 = grav*gor +! real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp +! real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g +! real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp +! real(kind=kind_phys), parameter :: pi2 = 2.*pi, pih = .5*pi +! real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 ! - real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) - real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) - - real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 - real(kind=kind_phys), parameter :: omega1 = pi2/86400. - real(kind=kind_phys), parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 - real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp - real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin - real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax - real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax +! real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) +! real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) +! real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 +! real(kind=kind_phys), parameter :: omega1 = pi2/86400., omega2 = 2.*omega1, omega3 = 3.*omega1 +! +! real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp +! real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin +! real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax +! real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax +! real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), +! real(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. +! real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 +! real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 +! real(kind=kind_phys), parameter :: arad = 6370.e3 end module ugwp_common + + subroutine init_nazdir(naz, xaz, yaz) + + use machine, only : kind_phys + use ugwp_common, only : pi2 + + implicit none + + integer :: naz + real(kind=kind_phys), dimension(naz) :: xaz, yaz + integer :: idir + real(kind=kind_phys) :: 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 ! ! !=================================================== @@ -55,21 +97,14 @@ end module ugwp_common !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - me, master) -! -! ccpp-damn con_pi !!! -! -!non-ccpp subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) -!non-ccpp use ugwp_common, only : pih - + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! use machine , only : kind_phys - + use ugwp_common, only : pih, pi implicit none integer , intent(in) :: me, master integer , intent(in) :: levs - real(kind=kind_phys), intent(in) :: con_pi real(kind=kind_phys), intent(in) :: zkm(levs), pmb(levs) ! in km-Pa real(kind=kind_phys), intent(out), dimension(levs+1) :: kvg, ktg, krad, kion ! @@ -94,15 +129,11 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & real(kind=kind_phys), parameter :: zdrag = 100. real(kind=kind_phys), parameter :: zgrow = 50. ! - real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag + real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag real(kind=kind_phys) :: rf_fv3, rtau_fv3, ptop, pih_dlog ! real(kind=kind_phys) :: ae1 ,ae2 ! -! ccpp con_pi -! - real(kind=kind_phys) :: pih - pih = 0.5*con_pi ptop = pmb(levs) rtau_fv3 = 1./86400./tau_alp @@ -141,14 +172,14 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & 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) ... init_global_gwdis' - 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)) +! if (me == master) then +! write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ... init_global_gwdis' +! 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 ! @@ -161,7 +192,7 @@ end subroutine init_global_gwdis ! !========================================================================= module ugwp_oro_init - use machine , only : kind_phys + use machine , only : kind_phys use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi use ugwp_common, only : mkzmin, mkz2min implicit none @@ -182,6 +213,7 @@ module ugwp_oro_init character(len=8) :: strver = 'gfs_2018' character(len=8) :: strbase = 'gfs_2018' + real(kind=kind_phys), parameter :: rimin=-10., ric=0.25 real(kind=kind_phys), parameter :: frmax=10., frc =1.0, frmin =0.01 @@ -190,9 +222,10 @@ module ugwp_oro_init real(kind=kind_phys), parameter :: efmin=0.5, efmax=10.0 real(kind=kind_phys), parameter :: rlolev=50000.0 - integer,parameter :: mdir = 8 - real(kind=kind_phys), parameter :: fdir=.5*mdir/pi - + integer, parameter :: mdir = 8 + real(kind=kind_phys), parameter :: fdir=mdir/(8.*atan(1.0)) + real(kind=kind_phys), parameter :: zpgeo=2.*atan(1.0) + integer nwdir(mdir) data nwdir/6,7,5,8,2,3,1,4/ save nwdir @@ -202,14 +235,14 @@ module ugwp_oro_init real(kind=kind_phys), parameter :: fcrit_gfs = 0.7, fcrit_v1 = 0.7 real(kind=kind_phys), parameter :: fcrit_mtb = 0.7 - real(kind=kind_phys), parameter :: zbr_pi = (1.0/2.0)*pi - real(kind=kind_phys), parameter :: zbr_ifs = 0.5*pi + real(kind=kind_phys), parameter :: zbr_pi = zpgeo + real(kind=kind_phys), parameter :: zbr_ifs = zpgeo ! real(kind=kind_phys), parameter :: kxoro=6.28e-3/200. ! real(kind=kind_phys), parameter :: coro = 0.0 - integer,parameter :: nridge=2 + integer,parameter :: nridge=2 real(kind=kind_phys), parameter :: sigma_std=1./100., gamm_std=1.0 real(kind=kind_phys) :: cdmb ! scale factors for mtb @@ -291,8 +324,10 @@ end module ugwp_oro_init ! !========================================================================= module ugwp_conv_init + use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + + implicit none real(kind=kind_phys) :: eff_con ! scale factors for conv GWs integer :: nwcon ! number of waves @@ -313,17 +348,9 @@ module ugwp_conv_init real(kind=kind_phys), allocatable :: xaz_conv(:), yaz_conv(:) contains ! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - con_pi, arad, lonr, kxw) -! -! non-ccpp with use ugwp_common -! -! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & -! lonr, kxw) + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) ! -! use ugwp_common, only : pi2, arad - - + use ugwp_common, only : pi2, arad implicit none @@ -333,7 +360,6 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & ! ! ccpp ! - real(kind=kind_phys) :: con_pi, arad real(kind=kind_phys) :: kxw, effac real(kind=kind_phys) :: work1 = 0.5 @@ -345,7 +371,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & nstcon = nstoch eff_con = effac - con_dlength = 2.0*con_pi*arad/float(lonr) + con_dlength = pi2*arad/float(lonr) ! ! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" ! @@ -370,7 +396,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & snorm = sum(spf_conv) spf_conv = spf_conv/snorm*1.5 - call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) + call init_nazdir(nazdir, xaz_conv, yaz_conv) end subroutine init_conv_gws @@ -383,7 +409,8 @@ end module ugwp_conv_init module ugwp_fjet_init use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + + implicit none real(kind=kind_phys) :: eff_fj ! scale factors for conv GWs @@ -401,18 +428,14 @@ module ugwp_fjet_init real(kind=kind_phys), allocatable :: xaz_fjet(:), yaz_fjet(:) contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) -! non-ccpp -! -! subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) -! use ugwp_common, only : pi2, arad + 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(kind=kind_phys) :: con_pi real(kind=kind_phys) :: kxw, effac , chk integer :: k @@ -433,7 +456,7 @@ subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & ch_fjet(k) = chk spf_fjet(k) = 1.0 enddo - call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) + call init_nazdir(nazdir, xaz_fjet, yaz_fjet) end subroutine init_fjet_gws @@ -444,8 +467,8 @@ end module ugwp_fjet_init ! module ugwp_okw_init !========================================================================= - use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + use machine , only : kind_phys + implicit none real(kind=kind_phys) :: eff_okw ! scale factors for conv GWs @@ -463,17 +486,15 @@ module ugwp_okw_init contains ! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) + -! subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) -! use ugwp_common, only : pi2, arad + 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(kind=kind_phys) :: con_pi real(kind=kind_phys) :: kxw, effac , chk integer :: k @@ -493,10 +514,8 @@ subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & ch_okwp(k) = chk spf_okwp(k) = 1. enddo - - call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) -! non-ccpp -! call init_nazdir(nazdir, xaz_okwp, yaz_okwp) + + call init_nazdir(nazdir, xaz_okwp, yaz_okwp) ! end subroutine init_okw_gws @@ -557,10 +576,11 @@ end module ugwp_lsatdis_init ! ! module ugwp_wmsdis_init + use machine , only : kind_phys 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, only : mkzmin, mkz2min, mkzmax, mkz2max, ucrit => cdmin implicit none @@ -569,7 +589,7 @@ module ugwp_wmsdis_init real(kind=kind_phys), parameter :: gptwo=2.0 - real(kind=kind_phys) , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real(kind=kind_phys) , parameter :: bnfix = 6.28/300., bnfix2= bnfix * bnfix real(kind=kind_phys) , parameter :: bnfix4 = bnfix2 * bnfix2 real(kind=kind_phys) , parameter :: bnfix3 = bnfix2 * bnfix ! @@ -577,7 +597,6 @@ module ugwp_wmsdis_init ! integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum - real(kind=kind_phys) , parameter :: ucrit=cdmin real(kind=kind_phys) , parameter :: zcimin = 2.5 real(kind=kind_phys) , parameter :: zcimax = 125.0 @@ -684,13 +703,13 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, allocate ( zcosang(nazd), zsinang(nazd) ) allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) - if (me == master) then - print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' +! if (me == master) then +! print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' ! - print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch - print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. - print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 - endif +! print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch +! print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. +! print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 +! endif zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. @@ -763,13 +782,16 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, enddo zdx = (zci(nwav)-zci(1))/ real(nwav-1) - do inc=1, nwav + do inc=1, nwav zdci(inc) = zdx - enddo + enddo - cstar = bnfix/zms - rcstar = 1./cstar - + cstar = bnfix/zms + rcstar = 1./cstar + ENDIF ! if (version == 1) then + + RETURN +!=================== Diag prints after return ==================== if (me == master) then print * print *, 'ugwp_v0: zcimin=' , zcimin @@ -788,15 +810,16 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, print * nslope3=nslope+3.0 - do inc=1, nwav - zcin =zci(inc)*rcstar - fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) - fpc_dc = fpc * zdci(inc) - write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) - enddo + do inc=1, nwav + zcin =zci(inc)*rcstar + fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) + 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 - ENDIF ! if (version == 1) then + + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) end subroutine initsolv_wmsdis diff --git a/physics/cires_ugwpv1_module.F90 b/physics/cires_ugwpv1_module.F90 index eb740c7eb..13b7752a5 100644 --- a/physics/cires_ugwpv1_module.F90 +++ b/physics/cires_ugwpv1_module.F90 @@ -10,7 +10,7 @@ module cires_ugwpv1_module ! ! use machine, only : kind_phys - use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar use ugwp_wmsdis_init, only : tau_min, tamp_mpa @@ -22,6 +22,7 @@ module cires_ugwpv1_module logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver integer, parameter :: idebug_gwrms=0 ! control for diag computaions pw wind-temp GW-rms and MF fluxs logical, parameter :: do_adjoro = .false. + real(kind=kind_phys), parameter :: max_kdis = 450. ! 400 m2/s real(kind=kind_phys), parameter :: max_axyz = 450.e-5 ! 400 m/s/day real(kind=kind_phys), parameter :: max_eps = max_kdis*4.e-4 ! max_kdis*BN2 @@ -39,15 +40,8 @@ module cires_ugwpv1_module real(kind=kind_phys), parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw real(kind=kind_phys), parameter :: iPr_turb =1./3., iPr_mol =1.95 - - real(kind=kind_phys), parameter :: hps = hpscale - real(kind=kind_phys), parameter :: hpskm = hps/1000. -! - real(kind=kind_phys), parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 - real(kind=kind_phys), parameter :: khp = 0.287*rhp1 ! R/Cp/Hp - real(kind=kind_phys), parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model - real(kind=kind_phys), parameter :: linsat = 1.00 + real(kind=kind_phys), parameter :: linsat = 1.00 real(kind=kind_phys), parameter :: linsat2 = linsat*linsat real(kind=kind_phys), parameter :: ricrit = 0.25 @@ -75,41 +69,26 @@ module cires_ugwpv1_module real(kind=kind_phys) :: knob_ugwp_taumin = 0.25e-3 real(kind=kind_phys) :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) real(kind=kind_phys) :: knob_ugwp_lhmet = 200.e3 ! 200 km + logical :: knob_ugwp_tlimb = .true. character(len=8) :: knob_ugwp_orosolv='pss-1986' - real(kind=kind_phys) :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes -! -! tune-ups for qbo -! -! real(kind=kind_phys) :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs -! real(kind=kind_phys) :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians -! real(kind=kind_phys) :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing -! real(kind=kind_phys) :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO -! real(kind=kind_phys) :: knob_ugwp_qbotau = 10. ! relaxation time scale in days -! real(kind=kind_phys) :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing -! real(kind=kind_phys) :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing -! 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(kind=kind_phys), parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. -! integer :: nqbo_d1y, nqbo_d2z, nqbo_d3t - + real(kind=kind_phys) :: kxw = 6.28/200.e3 ! single horizontal wavenumber of ugwp schemes +! integer :: ugwp_azdir integer :: ugwp_stoch integer :: ugwp_src integer :: ugwp_nws + real(kind=kind_phys) :: ugwp_effac - ! 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_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & knob_ugwp_tlimb, knob_ugwp_orosolv ! @@ -119,17 +98,11 @@ module cires_ugwpv1_module real(kind=kind_phys), allocatable :: kvg(:), ktg(:), krad(:), kion(:) real(kind=kind_phys), allocatable :: zkm(:), pmb(:) real(kind=kind_phys), allocatable :: rfdis(:), rfdist(:) - integer :: levs_rf +! +! RF-not active now +! + integer :: levs_rf real(kind=kind_phys) :: pa_rf, tau_rf -!........................................................................................... -! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run -!........................................................................................... - -! integer :: ntau_d1y, ntau_d2t -! real(kind=kind_phys), allocatable :: ugwp_taulat(:) -! real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) -! logical :: flag_alloctau = .false. -! character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' ! ! simple modulation of tau_ngw by the total rain/precip strength ! @@ -300,11 +273,10 @@ subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & print *, 'cires_ugwpv1 klev_ngw =', launch_level, nint(pmb(launch_level)) endif ! -! Part-1 :init_global_gwdis again "damn"-con_pi -! call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! Part-1 :init_global_gwdis again "damn"-con_p ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - me, master) + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) + ! ! Part-2 :init_SOURCES_gws ! @@ -321,30 +293,30 @@ subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & IF (do_physb_gwsrcs) THEN - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' +! if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' 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), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' + 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), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' + lonr, kxw ) +! if (me == master) print *, ' init_fjet_gws ' endif if (knob_ugwp_wvspec(2) > 0) then ! conv : con_pi, con_rerth, call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), & - con_pi, con_rerth, lonr, kxw ) - if (me == master) & - print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + lonr, kxw ) +! if (me == master) & +! print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) endif diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 6913b4c0e..46191f404 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -3,7 +3,6 @@ module cires_ugwpv1_oro contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & - grav, con_omega, rd, cpd, rv, pi, arad, fv, & xlatd, sinlat, coslat, sparea, & cdmbgwd, hprime, oc, oa4, clx4, theta, sigmad, & gammad, elvmaxd, sgh30, kpbl, & @@ -13,18 +12,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_ofdcol, dv_ofdcol, errmsg,errflg ) - -! call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & -! con_g, con_omega, con_rd, con_cp, con_rv,con_pi, con_rerth, con_fvirt, & -! xlat_d, sinlat, coslat, area, & -! cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & -! sigma, gamma, elvmax, varss, kpbl, & -! ugrs, vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & -! Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & -! zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & -! dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & -! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & -! du_ofdcol, dv_ofdcol, errmsg,errflg ) !--------------------------------------------------------------------------- ! ugwp_v1: orogw_v1 following recent updates of Lott & Miller 1997 @@ -42,19 +29,21 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! cdmbgwd(1) = 1 for all resolutions, number of hills control SA-effects ! cdmbgwd(2) = 1 ...............number of hills control SA-effects ! -! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) +! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) ! alternative lheff = min( dogw=hprime/sigma*gamma, dx) ! we still not use the "broad spectral solver" ! -! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW +! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW ! -! (e) for linsat-solver "eddy" damping Ked = Ked * Nhills, scale-aware -! amplification of the momentum deposition for low-res simulations +! (e) for linsat-solver the total "eddy" damping Ked = Ked * Nhills, +! scale-aware amplification of the momentum deposition for low-res runs !---------------------------------------- use machine , only : kind_phys - use ugwp_common, only : dw2min, velmin - + use ugwp_common, only : dw2min, velmin, grav, omega1, rd, cpd, rv, pi, arad, fv + use ugwp_common, only : rcpdt, grav2, rgrav, rcpd, rcpd2 + use ugwp_common, only : rad_to_deg, deg_to_rad, pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min + use ugwp_oro_init, only : rimin, ric, efmin, efmax, & hpmax, hpmin, sigfaci => sigfac, & dpmin, minwnd, hminmt, hncrit, & @@ -65,8 +54,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & n_tofd, ze_tofd, ztop_tofd use cires_ugwpv1_module, only : kxw, max_kdis, max_axyz - -! use cires_ugwpv1_sporo, only : oro_spectral_solver !---------------------------------------- implicit none @@ -103,9 +90,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & 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) :: & @@ -134,17 +119,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! -!--------------------------------------------------------------------- -! # 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 vars for SSO ! @@ -208,14 +182,14 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & 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) :: 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 - real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad - real(kind=kind_phys) :: pi2, pi2h, rdi, gor, grcp, gocp, gr2, bnv2min +! real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad +! real(kind=kind_phys) :: pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min real(kind=kind_phys) :: cleff_max ! resolution-aware max-wn real(kind=kind_phys) :: nonh_fact ! non-hydroststic factor 1.-(kx/kz_hh)**2 @@ -253,8 +227,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & !---- for lm and gwd calculation points ! ccpp-gwdps.f PARAMETER (hpmax=2400.0, hpmin=1.0) parameter (elvmax > hminmt=50.) - npt = 0 - + npt = 0 do i = 1,im if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then npt = npt + 1 @@ -262,38 +235,18 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & endif enddo - if (npt == 0) then - + if (npt == 0) then ! print *, 'orogw_v1 npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin - +! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin return ! no ogw/mbl calculation done endif -!=========================== -! scalars from phys-contants added by "CCPP-team" -! by rejecting to use "ugwp_common" -!=========================== - 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 - pi2h = 0.5*pi - rdi = 1.0/rd - gor = grav/rd - grcp = grav*rcpd - gocp = grcp - gr2 = grav*gor - bnv2min = (pi2/1800.)*(pi2/1800.) ! tau_BV_max = 30 min ! -!=========================== -! Start -! -! initialize gamma and sigma -! + + +!================================= +! Start if npt >= 1 +! initialize gamma and sigma for +! performing the QC of SSO inputs +!================================= gamma(:) = gammad(:) sigma(:) = sigmad(:) ! @@ -314,16 +267,14 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! sigma-degined as tan(angle) = h/2: L/2= h/L sigmin = hpmin/hdxres ! min-slope Hmin= 2*hpmin, dxres=Lmax - - - if ( kdt == -1 .and. me == master) then - print *, ' orogw_v1 scale2 ', cdmbgwd(2) - print *, ' orogw_v1 imx ', imx - print *, ' orogw_v1 gam_min ', gammin - print *, ' orogw_v1 sso_min ', sso_min - print *, ' orogw_v1 gam_min ', gammin - print *, ' orogw_v1 npt number of GRID-cells with hills ', npt - endif +! if ( kdt == 1 .and. me == master) then +! print *, ' orogw_v1 scale2 ', cdmbgwd(2) +! print *, ' orogw_v1 imx ', imx +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 sso_min ', sso_min +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 npt number of GRID-cells with hills ', npt +! endif !============================================================ ! Purpose to adjust oro-specification on the fly @@ -332,7 +283,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! width_mount_a = hprime/sigma < dxres cannot access dxres ! width_mount_b = width_mount_a * gamma ! -! Sellipse= pi a*b = (width_mount_a)^2 *gamma <= Sarea +! Sellipse= pi * a*b = (width_mount_a)^2 *gamma <= Sarea ! Limiters on "elongated" hills gamma= a/b < gam_min ! Limiters on "longest" hills (b, a) <= sqrt(area) ! @@ -362,7 +313,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & if (do_adjoro ) then ! -! more adjustments "lengths", gamma and sigma, valid assuminng H=2*hprime H/2 = hprime +! more adjustments "lengths", gamma and sigma, assuminng H_hill=2*hprime ! if (hprime(i) > hdxres*sigres) sigres= hprime(i)/dxres aelps = min( hprime(i)/sigres, hdxres) @@ -388,47 +339,45 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & gamma(i) = min(aelps/belps, 1.0) endif !aelps < sso_min - endif ! ============== (do_adjoro ) + endif ! if (do_adjoro ) - selps = belps*belps*gamma(i)*pi ! area of the elliptical hill - + selps = belps*belps*gamma(i)*pi ! area of the elliptical hill nhills = min(nhilmax, sparea(i)/selps) arhills(j) = max(nhills, 1.0) ! 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) - +! 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) enddo - 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) + !======================================================================= ! mtb-blocking : LM-1997; Zadra et al. 2004 ;metoffice dec 2010 H Wells !======================================================================= - do i=1,npt - khtop(i) = 2 - idxzb(i) = 0 - enddo + do i=1,npt + khtop(i) = 2 + idxzb(i) = 0 + izlow(i) = 1 + enddo - do k=1,km - do i=1,im + 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 enddo kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 - lcap = km ; lcapp1 = lcap + 1 - + lcap = km ; lcapp1 = lcap + 1 cdmb4 = 0.25*cdmb do i = 1, npt j = ipt(i) + elvmax(j) = min( sigfac * hprime(j), hncrit) ! -!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) Max-level of SSO-HILL -! - elvmax(j) = min ( sigfac * hprime(j), hncrit) - izlow(i) = 1 ! surface-level +!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) +! SSO-effects from the surface to "ELVMAX" =4*hprime + ELVMAX enddo @@ -444,193 +393,148 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & 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) + do i = 1, npt + j = ipt(i) + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) ! ! GFSv15/16: izlow=1 ! elvmax(j)=elvmaxd(J) + sig*hp: if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) khtop(i) = max(khtop(i), k+1 ) ! - if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(i), k+1 ) - if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) - - enddo + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(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 + 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 + taup(i,k) = 0.0 + enddo enddo ! ! perform ri_n or ri_mf computation for both OGW and OBL -! +!23456 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 - bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + 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 + 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 -! -! place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! having ri_n +! we may place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme ! - enddo + enddo enddo k = 1 +!23456 do i = 1, npt bnv2(i,k) = bnv2(i,k+1) enddo ! ! level khtop => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) -! +!23456 do i = 1, npt - j = ipt(i) - k_zlow = izlow(i) - if (k_zlow == khtop(i)) k_zlow = 1 - delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) -! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(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 + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == khtop(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(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 ! ! computation of the mean flow char zlow < z < ztop =sigfac*hprime -! - do k = k_zlow, khtop(i)-1 - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) - vbar(i) = vbar(i) + rdelks * v1(j,k) - roll(i) = roll(i) + rdelks * ro(i,k) - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - enddo +!23456 + do k = k_zlow, khtop(i)-1 + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo enddo -! +!23456 do i = 1, npt - j = ipt(i) + j = ipt(i) ! ! integrate from ztoph = sigfac*hprime down to zblk if exists ! find ph_blk, dz_blk as introduced in LM-97 and ifs -! - ph_blk =0. - do k = khtop(i), 1, -1 - - phiang = atan2(v1(j,k),u1(j,k)) - phiang = theta(j)*rad_to_deg - phiang - - if ( phiang > pi2h ) phiang = phiang - pi - if ( phiang < -pi2h ) phiang = phiang + pi - ang(i,k) = phiang - 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) +!23456 + ph_blk =0. + do k = khtop(i), 1, -1 + phiang = atan2(v1(j,k),u1(j,k)) + phiang = theta(j)*rad_to_deg - phiang + if ( phiang > pih ) phiang = phiang - pi + if ( phiang < -pih ) phiang = phiang + pi + ang(i,k) = phiang + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +!23456 + 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 -! --- LM97 - if ( ph_blk >= fcrit_v1 ) then - idxzb(i) = k - zobl (j) = zmet(j, k) - rdxzb(j) = real(k, kind=kind_phys) - endif - - endif - enddo -! -! fcrit_v1/fr_flow -! - goto 788 -! -! alternative expression for blocking: -! zobl = max(heff*(1. -fcrit_v1/fr_Flow), 0) -! -! - - 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_v1/fr), 0.0) - zw2 = zmet(j,2) - - if (fr > fcrit_v1 .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 - zobl (j) = zmet(j, k) - endif -788 continue +! --- LM97/IFS + if(ph_blk >= fcrit_v1 ) then + idxzb(i) = k + zobl (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif +!23456 + endif + enddo ! ! --- the drag for the blocked flow ! - if ( idxzb(i) > 0 ) then + if ( idxzb(i) > 0 ) then ! ! (4.16)-ifs description ! 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 -! -! empirical height dep-nt "blocking" length from LM-1997 + cgam = 0.48*gamma(j) + 0.30*gam2 + do k = idxzb(i)-1, 1, -1 +!23456 +! empirical height dep-nt "blocking" length from LM-1997/IFS ! - zlen = sqrt( (zobl(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 + zlen = sqrt( (zobl(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 + 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)) - - 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) +! aspect ratio of the elliptical hill seen by mean flow +! + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + sigres = max(sigmin, sigma(j)) + mtbridge = zr * sigres*zlen / hprime(j) +! dbtmp = cdmb4*mtbridge*max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) ! (4.15)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam * sinang2) ! (4.16)-ifs ! ! linear damping due to OBL [1/sec]=[U/L_block_orthogonal] ! more accurate along 2-axes of ellipse, here zr-factor is based on Phillips' analytics @@ -638,13 +542,13 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & db(i,k)= dbtmp * uds(i,k) ! if (db(i,k) > dbmax) print *, ' db > dbmax ', 1./db(i,k)/3600., uds(i,k) db(i,k)= min(db(i,k), dbmax) - enddo -! - endif + enddo +!23456 + endif enddo !............................. !............................. -! end mtn blocking section +! finish the mtn blocking !............................. !............................. ! @@ -657,78 +561,72 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & iwk(1:npt) = 2 ! ! in meto/UK-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations in taub_ogw +!23456 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 from the surface - enddo + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb from the surface + enddo enddo -! -! iwk - adhoc criteria to select ghe ogw-launch level between -! level ~0.4-0.5 km from surface or/and HPBL-top -! -! in all UGWP-schemes: zogw > zobl -! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb -! the top hill can be inside PBL.... if kref = khtop +! +! in all cires-UGWP-schemes: zogw > zobl +! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb +! the top of hill can be inside the PBL.... if kref = khtop ! kbps = 1 kmps = km k_mtb = 1 - +!23456 do i=1,npt - j = ipt(i) - k_mtb = max(1, idxzb(i)) + j = ipt(i) + k_mtb = max(1, idxzb(i)) ! WRF/GSL: kogw = max(kpbl, ktop=2*var) - kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime - kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime -! -! zogw > zobl -! - if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above blocking - 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 + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime + kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime +!zogw > zobl + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! OGW-layer above the blocking height + 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 +!23456===================== ! -! -!====================== we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb +!= we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb !computation of the mean flow for zobl < z < ztop =sigfac*hprime inb GSL ztop =max(hpbl, ztop) -!===================== - do i = 1,npt +!23456===================== + do i = 1,npt k_mtb = max(1, idxzb(i)) - do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) - 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 + do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) + if(k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo enddo ! ! orographic asymmetry parameters (oa), and (clx) [Kim & Arakawa Kim & Doyle] -! +!23456 do i = 1,npt - j = ipt(i) - wdir = atan2(ubar(i),vbar(i)) + pi ! not sure about "+pi" due to "nwdir"-Kim OA/CLX-processing - 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) ! number of "effective" hills in the grid-box KA-95/KD-05 + 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) ! number of "effective" hills (?) in the grid-box KA-95/KD-05 ! -!GSLdrag ->identical to above +!GSL-drag ->identical to above ! ! wdir = atan2(ubar(i),vbar(i)) + pi ! idir = mod(nint(fdir*wdir),mdir) + 1 @@ -736,23 +634,22 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) ! ol(i) = ol4(i,mod(nwd-1,4)+1) ! - dtfac(i) = 1.0 - icrilv(i) = .false. ! initialize critical level control Logic - - 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) + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control Logic + 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 +!23456 + 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 -! - 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 - do i = 1,npt - velco(i,km) = velco(i,kmm1) + do i = 1,npt + velco(i,km) = velco(i,kmm1) enddo ! !------------------------------------------------------------------------ @@ -772,94 +669,73 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! ! taub_oro as in KA-95/KD-05 GSL & EMC includes ALL waves (POGWs, Lee-rotors, etc...) ! here taub represents mainly OGWs with nonh_fact = 1. -(kx/kz)**2 -! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered -! +! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered +!23456 do i = 1,npt - j = ipt(i) - bnv = sqrt( bnv2bar(i) ) - heff = min(hprime(j),hpmax) - - if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac - - if (heff <= 0) cycle - zw1 = ulow(i)/bnv - hsat = fcrit_v1 *zw1 - heff = min(heff, hsat) ! similar hsat-limit in CAM as found in Dec 2020 - - fr = heff/zw1 ! Fr-GSL = Fr * OD -> gamma - - fr = min(fr, frmax) - fr2 = fr*fr - zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) - ! Fr-funct = zw2/(zw2+cg) -! + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac + if (heff <= 0) cycle + zw1 = ulow(i)/bnv + hsat = fcrit_v1 *zw1 + heff = min(heff, hsat) + fr = heff/zw1 + fr = min(fr, frmax) + fr2 = fr*fr + zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) +! ! [Kim & Doyle, 2005] ! - efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream - efact = min( max(efact,efmin), efmax ) - gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 + efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream + efact = min( max(efact,efmin), efmax ) + gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 ! -! !cleff_max(C768 = 6.28/(12.5 km/5.)) ..... +! ! cleff_max(C768 = 6.28/(12.5 km/5.)) ..... ! xlinv(i) = min(coefm * cleff, cleff_max) ! - mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 - - - xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) - - taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) + mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 + xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) + taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) ! ! old: tem = fr2*oc(j) ; gfobnv = gmax * tem / ((tem + cg)*bnv(i)) ! kx =or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge ! - sigres = sigma(j) - inv_b2eff = pi*sigres/heff ! pi2/(2b) - kxridge = pi /ahdxres(i) ! pi2/(2*dx) - xlingfs = max(inv_b2eff, kxridge) -! -! xlinv(i) = max(xlingfs, xlinv(i) ) - - nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 - - if ( nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U + sigres = sigma(j) + inv_b2eff = pi*sigres/heff ! pi2/(2b) + kxridge = pi /ahdxres(i) ! pi2/(2*dx) + xlingfs = max(inv_b2eff, kxridge) + nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 +!23456 + if (nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U ! - taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact - tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact + taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact + tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact ! -! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => -! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 -! - if ( fr > fcrit_v1 ) then -! - frnd = fr/fcrit_v1 - fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) - taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) - else - taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 - endif - xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 -! - 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 Bn2/U2= kz^2 -! -! diagnostics for zogw, tau_ogw -! - zogw(j) = zmeti(j, kref(i) ) - tau_ogw(j) = taub(i) - -! if (kdt == 1) then -! print *, ' tau =', nint(taub(i)*1.e3), ' tkd05 =', nint(taub_kd05(i)*1.e3), 'Fr=', Fr -! print *, ' zogw=', nint(zogw(j)), ' zobl=', nint(zobl(j)) ! nint(mkd05_hills(i)), nint(arhills(i)) -! endif - +! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => +! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 +!23456 + if(fr > fcrit_v1 ) then + frnd = fr/fcrit_v1 + fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) + taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) + else + taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 + endif + xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 + 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 Bn2/U2= kz^2 + zogw(j) = zmeti(j, kref(i) ) + tau_ogw(j) = taub(i) +!23456 enddo ! !----set up bottom values of stress ! - do i = 1,npt + do i = 1,npt taup(i, 1:kref(i) ) = taub(i) - enddo + enddo !====================================================== ! ! Having : taub(i)/tau_ogw(j) => solve for OGW-effects @@ -868,107 +744,85 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & if (strsolver == 'pss-1986') then !====================================================== -! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" -! modified by KD05 with the expression (11):below k=kref ??? +! v0-gfs orogw-solver of Palmer et al 1986 -"pss-1986" +! modified by KD05 with the emp.expression (11):below k=kref ??? ! tau(k+1) = tau(k)*Scorer(K+1)/Scorer(K) -! -! in v1-orogw linsatdis of "wam-2017" -! with llwb-mechanism for -! rotational/non-hydrostat ogws important for +! in v1-orogw linsatdis of "wam-2017" 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 +!23456====================================================== + 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 - zw1 = max(velco(i,k), velmin) - temv = 1.0 / zw1 + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + zw1 = max(velco(i,k), velmin) + temv = 1.0 / zw1 !=============== -! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB ??? only OA >0 +! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB only OA >0 ! k >= kref(i) and .... k+1 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 + 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 -! xlinv(i)*0.5 - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 - - hd = sqrt(taup(i,k) / tem1) - fro = brvf * hd * temv + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv ! ! rim is the "wave"-richardson number byPalmer,Shutts & Swinbank 1986 , PSS-1986 ! - tem2 = sqrt(ri_n(i,k)) - tem = 1. + tem2 * fro - ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) -! -! check Ri-stability to employ the 'dynamical saturation hypothesis' PSS-1986 -! assuming co-existence of Dyn-Ins and Conv-Ins -! - if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then - temc = 2.0 + 1.0 / tem2 - hd = zw1 * (2.*sqrt(temc)-temc) / brvf - taup(i,kp1) = tem1 * hd * hd - else - - taup(i,kp1) = taup(i,k) * rscor - endif + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check Ri-stability to employ the 'dynamical criterion' of PSS-1986 +! assuming co-existence of simultaneous Dyn-Ins and Conv-Ins +! cos(GW_phase) =1 and sin(GW_phase)=-1 +!23456 + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = zw1 * (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 ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) - endif ! k >= kref(i)) - enddo ! oro-points - enddo ! do k = kmps, kmm1 vertical level loop -! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) + endif ! k >= kref(i)) + enddo ! oro-points + enddo ! do k = kmps, kmm1 vertical level loop +!23456 ! zero momentum deposition at the top model layer: taup(k+1) = taup(k) ! 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 - zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) -!====================================================================================== -! we estimated "impact" of the single sub-grid hill, we have "arhills" in the grid-box -! 2-estimations of "nhills": 1) geometry-arhills and 2) KDO5 mkd05_hills -! for OBL we used: 1) nhills=Grid_Area/Hill_area -! nhills = max(mkd05_hills(i), arhills(i)) -! Trapped "Lee" downslope wave regimes are not properly modelled: vertical shear +NH/Nonlin -! tau(z) = const => tau(z)/m2(z) = const (empirical mesoscale) -! -! Apply dU/dt-limiter -! +!23456 + do k = 1,km + do i = 1,npt + zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) !====================================================================================== -! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hill_area -! apply limiters for OGW tendency +! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hil +! apply limiters for OGW tendency !====================================================================================== - if (abs(zw1) > max_axyz ) then - zw1 = sign(max_axyz, zw1) -! if (kdt <=2 ) then -! print *, ' Hdudt ', nint(max_axyz*1.e5), nint(zw2*1.e5) -! print *, ' Hdudt ', xn(i), yn(i) -! endif - endif - taud(i,k)= zw1 - enddo - enddo - + if (abs(zw1) > max_axyz ) zw1 = sign(max_axyz, zw1) + taud(i,k)= zw1 + enddo + enddo +!23456 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ !------if the gravity wave drag would force a critical line in the !------layers below sigma=rlolev during the next deltim timestep, @@ -977,168 +831,140 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! 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 variations in "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 +!23456~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev .and. taud(i,k) /= 0.) then + tem = dtp * taud(i,k) + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +!default : dtfac(i) = 1.0 + endif + enddo + enddo ! -!--------- orogw-solver of gfs PSS-1986 is performed - +!--------- orogw-solver of gfs PSS-1986 is performed else - -!----------- orogw-solver of wam2017 out : taup, taud, pkdis - - dtfac(:) = 1.0 - - call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & - dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & - grav, con_omega, rd, & +!----------orogw-solver of wam2017 out : taup, taud, pkdis + + call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, omega1, rd, & del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) - endif ! oro_linsat - linsatdis-solver for stationary OGWs + endif ! oro_linsat - linsatdis-solver for stationary OGWs ! !---- above orogw-solver of wam2017------------ ! ! tofd as in Beljaars-2004 IFS sep-scale ~5km ! CESM ~ 6km (TMS + OGW/OBL) -! sgh30 = varss of GSL (?) +! sgh30 = varss of GSL ! ---------------------------------------------- - - if( do_tofd ) then -! -! can scale varss(j) by adjusting filterd oro_turb spectra -! a1-coeff by (Lx_flt_cXXX/Lx_c768)^1.9 -! -! klow = 6.28/10km of Beljaars_etal_2004 and kflt^n1 -! kflt = 6.28/18km -! if ( kdt == 1 .and. me == 0) then -! print *, 'ugwp-v1 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 - ! GSL-2/limits a) 250 m ; b) var_maxfd =150m - zsurf = zmeti(j,1) - - do k=1,km - zpm(k) = zmet(j,k) - up1(k) = u1(j,k) - vp1(k) = v1(j,k) - enddo +!23456 + if( do_tofd ) then + 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 GSL-2/limits a) 250 m ; b) var_maxfd =150m + 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, cpd, dtp, sigflt, zsurf, zpbl, & - up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + call ugwp_tofd1d(km, cpd, dtp, sigflt, zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - do k=1,km - dudt_ofd(j,k) = utofd1(k) - dvdt_ofd(j,k) = vtofd1(k) + do k=1,km + dudt_ofd(j,k) = utofd1(k) + dvdt_ofd(j,k) = vtofd1(k) ! ! add tofd to gw-tendencies ! - pdvdt(j,k) = pdvdt(j,k) + utofd1(k) - pdudt(j,k) = pdudt(j,k) + vtofd1(k) - pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) - enddo -!2018-diag - du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) - dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) + pdvdt(j,k) = pdvdt(j,k) + utofd1(k) + pdudt(j,k) = pdudt(j,k) + vtofd1(k) + pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) + enddo + du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) + dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) - dusfc(j) = dusfc(j) + du_ofdcol(j) - dvsfc(j) = dvsfc(j) + dv_ofdcol(j) - enddo + dusfc(j) = dusfc(j) + du_ofdcol(j) + dvsfc(j) = dvsfc(j) + dv_ofdcol(j) + enddo endif ! do_tofd - +!23456 !-------------------------------------------- ! combine oro-drag effects MB +TOFD + OGWs + diag-3d !-------------------------------------------- -! - +!234546 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 + 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 +! if blocking layers -- no ogw effects ! - dbim = db(i,k) / (1.+db(i,k)*dtp) - - dudt_obl(j,k) = -dbim * u1(j,k) - dvdt_obl(j,k) = -dbim * v1(j,k) + dbim = db(i,k) / (1.+db(i,k)*dtp) + dudt_obl(j,k) = -dbim * u1(j,k) + dvdt_obl(j,k) = -dbim * v1(j,k) - pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) - pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) -!2018-diag - du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) - dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) - - dusfc(j) = dusfc(j) + du_oblcol(j) - dvsfc(j) = dvsfc(j) + dv_oblcol(j) - - else + pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) + pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) + du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) + dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) + dusfc(j) = dusfc(j) + du_oblcol(j) + dvsfc(j) = dvsfc(j) + dv_oblcol(j) +!23456 + else ! ! ogw-s above blocking height ! - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) ! - dudt_ogw(j,k) = dtaux - dvdt_ogw(j,k) = dtauy + dudt_ogw(j,k) = dtaux + dvdt_ogw(j,k) = dtauy ! - pdvdt(j,k) = dtauy +pdvdt(j,k) - pdudt(j,k) = dtaux +pdudt(j,k) + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) ! - du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) - dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) + du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) + dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) ! - dusfc(j) = dusfc(j) + du_ogwcol(j) - dvsfc(j) = dvsfc(j) + dv_ogwcol(j) - endif + dusfc(j) = dusfc(j) + du_ogwcol(j) + dvsfc(j) = dvsfc(j) + dv_ogwcol(j) + endif +!23456 !============ ! local energy deposition sso-heat due to loss of kinetic energy !============ - unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp - vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp - eng1 = 0.5*(unew*unew + vnew*vnew) - pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) - - enddo + unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) + enddo enddo ! dusfc w/o tofd sign as in the era-i, merra and cfsr +!23456 do i = 1,npt - j = ipt(i) - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) du_ogwcol(j) = -rgrav *du_ogwcol (j) dv_ogwcol(j) = -rgrav *dv_ogwcol (j) du_oblcol(j) = -rgrav *du_oblcol (j) dv_oblcol(j) = -rgrav *dv_oblcol (j) - tau_ogw(j) = -rgrav * tau_ogw(j) - du_ofdcol(j) = -rgrav * du_ofdcol(j) - dv_ofdcol(j) = -rgrav * du_ofdcol(j) + du_ofdcol(j) = -rgrav * du_ofdcol(j) + dv_ofdcol(j) = -rgrav * du_ofdcol(j) enddo - return + return -!============ debug ------------------------------------------------ +!============ print/debug after the RETURN statenemt -------------------------------- if (kdt <= 2 .and. me == 0) then print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me ! @@ -1185,12 +1011,12 @@ end subroutine orogw_v1 subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd + use machine , only : kind_phys + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd ! ! adding the implicit tendency estimate ! - implicit none + implicit none integer, intent(in) :: levs real(kind_phys), intent(in) :: con_cp real(kind_phys), intent(in) :: dtp @@ -1198,16 +1024,15 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & real(kind_phys), intent(in), dimension(levs) :: u, v, zmid real(kind_phys), intent(in) :: sigflt, zpbl, zsurf - real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd - - + real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd ! ! locals ! integer :: i, k real(kind=kind_phys) :: rcpd2, tofd_mag, tofd_zdep - real(kind_phys) :: unew, vnew, eknew - real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer + real(kind_phys) :: unew, vnew, eknew + + real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer real(kind=kind_phys), parameter :: tend_imp = 1. @@ -1222,10 +1047,10 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & ! H_efold = min(H_efold,1500.) rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! dz ~25m of the first layer in FV3GFS-127L + tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res -! GSL-scheme: varmax_fd, beta_fd ,250. +! GSL-darg scheme: varmax_fd, beta_fd ,250. ! var_temp = MIN(varss,varmax_fd) + MAX(0., 0.1*(varss-varmax_fd)) ! var_temp = MIN(var_temp, 250.) ! var_temp = var_temp * var_temp @@ -1257,7 +1082,7 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & krf = umag * tofd_mag * tofd_zdep if (tend_imp == 1.) then - krf = krf/(1.+krf*dtp) + krf = krf/(1.+krf*dtp) endif utofd(k) = -krf*u(k) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index ad8f8090d..07330cf8b 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -10,16 +10,10 @@ module cires_ugwpv1_solv2 ! reflected GWs treated as waves with "negligible" flux, ! they are out of given column !--------------------------------------------------- -! call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & -! tau_ngw, 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, & -! dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- @@ -56,8 +50,6 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! implicit none ! - real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt - real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 integer, parameter :: ener_norm =0 @@ -201,23 +193,22 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & iPr_max = max(1.0, iPr_ktgw) gipr = grav* Ipr_ktgw ! -! test for input fields -! - 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 ' +! test for input fields +! 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 +! endif if (idebug_gwrms == 1) then tauabs=0.0; wrms =0.0 ; trms =0.0 @@ -234,7 +225,9 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & km1 = ksrc - 1 kp1 = ksrc + 1 ktop= levs+1 - suprf(ktop) = kion(levs) + + suprf(ktop) = kion(levs) + do k=1,levs suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 pdvdt(:,k) = 0.0 @@ -246,8 +239,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & !----------------------------------------------------------- ! column-based j=1,im pjysics with 1D-arrays !----------------------------------------------------------- - DO j=1, im - + DO j=1, im jl =j tx1 = omega2 * sinlat(j) *rv_kxw cf1 = abs(tx1) @@ -302,26 +294,26 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! 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)) + 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) + zthm = 2.0/(tvc+tvm) rhp_wam = zthm*gor !interface - uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) - vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) - tint(jk) = 0.5 *(tvc+tvm) + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) rhomid(jk) = aprsl(jk)*rdi/atm(jk) rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) zdelp = dz_meti(jk) ! >0 ...... dz-meters v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters ! -! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) ! - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) bn(jk) = sqrt(bn2(jk)) @@ -1015,7 +1007,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! RETURN -!================================= +!================================= diag print after "return" ====================== if (kdt ==1 .and. mpi_id == master) then ! print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 index 98eca419e..c840b49d8 100644 --- a/physics/cires_ugwpv1_sporo.F90 +++ b/physics/cires_ugwpv1_sporo.F90 @@ -1,10 +1,11 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & - grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) ! - USE MACHINE , ONLY : kind_phys + use machine , only : kind_phys + use ugwp_common, only : grav, omega2, rd ! implicit none @@ -24,7 +25,6 @@ subroutine oro_spectral_solver(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 ! @@ -44,7 +44,7 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & 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 :: 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 @@ -124,12 +124,12 @@ subroutine oro_spectral_solver(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,:), grav, con_rd, & + & prsi(j,:), prsL(j,:), & & del(j,:), rho(i,:), & & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & & xn(i), yn(i)) - fcor2 = (2*omega*sinlat(j))*(2*omega*sinlat(j))*fc_flag + fcor2 = omega2*sinlat(j)*omega2*sinlat(j)*fc_flag k = ksrc @@ -152,11 +152,11 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & ! ! if (cxoro(iw) > cxmin) then - wave_act(iw,k:levs+1) = 0. ! crit-level + 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 + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off else kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) kzw = sqrt(kzw2) @@ -199,7 +199,7 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & wave_act(iw,k:levs+1) = 0.0 else ! -! upward propagation w/o reflection +! upward propagation w/o reflection effects ! kxw = akx(iw) kzw = sqrt(kzw2) @@ -283,18 +283,17 @@ end subroutine oro_spectral_solver ! !------------------------------------------------------------- subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & - & grav, con_rd, & - & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) use machine , only : kind_phys - use ugwp_common , only : velmin, dw2min + use ugwp_common , only : velmin, dw2min, rdi, grav, rgrav, hpscale, rhp, rh4 implicit none - + integer :: nz, nzi real(kind=kind_phys), dimension(nz ) :: u1, v1, t1, delp, rho, pmid real(kind=kind_phys), dimension(nz ) :: bn2 ! define at the interfaces real(kind=kind_phys), dimension(nz+1) :: pint real(kind=kind_phys) :: xn, yn - real(kind=kind_phys),intent(in) :: grav, con_rd + ! output real(kind=kind_phys), dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp @@ -303,24 +302,23 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & integer :: i, j, k real(kind=kind_phys) :: ui, vi, ti, uz, vz, shr2, rdz, kamp real(kind=kind_phys) :: zgrow, zmet, rdpm, ritur, kmol, w1 - real(kind=kind_phys) :: rgrav, rdi + ! paremeters - real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 - real(kind=kind_phys), parameter :: rhps=1.0/hps - real(kind=kind_phys), parameter :: h4= 0.25/hps - real(kind=kind_phys), parameter :: rimin = 1.0/8.0, kedmin = 0.01 - real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 +! real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 +! real(kind=kind_phys), parameter :: rhps=1.0/hps +! real(kind=kind_phys), parameter :: h4= 0.25/hps + + real(kind=kind_phys), parameter :: rimin = 0.125, kedmin = 0.01 + real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 real(kind=kind_phys), parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb - kalp(1:nzi) = 2.e-7 ! radiative damping - - rgrav = 1.0/grav - rdi = 1.0/con_rd + + kalp(1:nzi) = 2.e-7 ! radiative damping scale 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 + uzi(k) = ui*xn + vi*yn ti = .5*(t1(k-1)+t1(k)) rhoi(k) = rdi*pint(k)/ti rdz = rdpm *rhoi(k) @@ -328,13 +326,13 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & 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 + zmet = -hpscale*alog(pint(k)*1.e-5) + zgrow = exp(zmet*rh4) + kmol = 2.e-5*exp(zmet*rhp) + kedmin ritur = max(bn2(k)/shr2, rimin) kamp = sqrt(shr2)*lsc2 *zgrow w1 = 1./(1. + 5*ritur) - ktur(k) = kamp * w1 * w1 +kmol + ktur(k) = kamp * w1 * w1 + kmol enddo k = 1 diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 index db95a4f87..3c42e573b 100644 --- a/physics/cires_ugwpv1_triggers.F90 +++ b/physics/cires_ugwpv1_triggers.F90 @@ -4,7 +4,6 @@ module cires_ugwpv1_triggers contains - ! ! ! @@ -177,87 +176,8 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5 - - subroutine init_nazdir(con_pi, naz, xaz, yaz) - implicit none - real(kind=kind_phys) :: con_pi - integer :: naz - real(kind=kind_phys), dimension(naz) :: xaz, yaz - integer :: idir - real(kind=kind_phys) :: phic, drad - real(kind=kind_phys) :: pi2 - pi2 = 2.0*con_pi - 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 -!========================================================================= -! Below subroutine that can be activated after "testing" and extra-work" -!========================================================================= - subroutine emc_modulation(im , levs, ntke, tau_ngw, cdmb3, cdmb4, dtp, & - q_tke, dqdt_tke, del, rain) - - integer, intent(in) :: im , levs, ntke - real(kind=kind_phys), intent(in) :: cdmb3, cdmb4, dtp - real(kind=kind_phys), intent(in) :: rain(im) - real(kind=kind_phys), intent(inout) :: tau_ngw(im) - real(kind=kind_phys), intent(in), dimension(im,levs) :: q_tke, dqdt_tke, del - -! locals - - - real(kind=kind_phys) :: turb_fac, tem - real(kind=kind_phys) :: rfac, tx1, tke - + end subroutine slat_geos5 -!============ -! -! below the "EMC-proposal" in May 2019 without rigorous tests reported elsewhere -! can be eliminated due to "lack" of validations and -! in GFSv16 cdmbgwd(3) =1.0 and the next if-loop is "cosmetic" proposal -! -!============ - if (1.0-cdmb3 > 1.0e-6) then - rfac = 86400000. / dtp !??? -! -! in operations cdmbgwd(3) = 1 in GFSv16, and code below is not executed -! - if (cdmb4 > 0.0) then - do i=1,im - turb_fac = 0.0 - if (ntke > 0) then - tem = 0.0 - do k=1,(levs+levs)/3 ! ???? - tke = q_tke(i,k) + dqdt_tke(i,k) * dtp - turb_fac = turb_fac + del(i,k) * tke - tem = tem + del(i,k) - enddo - turb_fac = turb_fac / tem - endif - tx1 = cdmb4*min(10.0, max(turb_fac,rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) * cdmb3 !???? - enddo - endif - endif - end subroutine emc_modulation - - !=============================================== ! ! Spontaneous GW triggers by dynamical inbalances (OKW, fronts/jets, and convection) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 252838ca1..20ab38897 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -37,22 +37,14 @@ module ugwpv1_gsldrag use machine, only: kind_phys + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 - use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp - use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa - use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 - use cires_ugwpv1_oro, only: orogw_v1 -! use cires_ugwp1_sporo, only: oro_spectral_solver - - use drag_suite, only: drag_suite_run - -! use cires_ugwpv1_triggers, only: get_spectra_tau_convgw, get_spectra_tau_okw, get_spectra_tau_nstgw -! use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 -! use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 -! use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 -! 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 cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 + + use drag_suite, only: drag_suite_run implicit none @@ -77,10 +69,13 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & 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, do_ugwp_v1_w_gsldrag, errmsg, errflg) + use ugwp_common + !---- initialization of unified_ugwp implicit none @@ -97,6 +92,7 @@ subroutine ugwpv1_gsldrag_init ( & real(kind=kind_phys), intent (in) :: dtp real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt logical, intent (in) :: do_ugwp logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & @@ -118,12 +114,32 @@ subroutine ugwpv1_gsldrag_init ( & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 -!============================================= -! 3 cases for ORO-schemes + NGWs: -! gwd_opt => "1 and 2, 3, 22, 33' +!============================================================================ +! +! gwd_opt => "1 and 2, 3, 22, 33' see previous GSL-commits +! related to GSL-oro drag suite +! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography +! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 +! FV3GFS_io.F90: if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & +! FV3GFS_io.F90: Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then +! FV3GFS_io.F90: if ( (Model%gwd_opt==3 .or. Model%gwd_opt==33) .or. & +! FV3GFS_io.F90: ( (Model%gwd_opt==2 .or. Model%gwd_opt==22) .and. & +! +! gwd_opt=1 -current 14-element GFS-EMC subgrid-oro input +! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input +! GSL uses the gwd_opt flag to control "extra" diagnostics (22 and 33) +! CCPP may use gwd_opt to determine 14 or 24 variables for the input +! but at present you work with "nmtvr" +! GFS_GWD_generic.F90: integer, intent(in) :: im, levs, nmtvr +!GFS_GWD_generic.F90: real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) +!GFS_GWD_generic.F90: if (nmtvr == 14) then ! gwd_opt=1 current operational - as of 2014 +!GFS_GWD_generic.F90: elseif (nmtvr == 10) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 6) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp gwd_opt=2,3 +! ! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 -! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp -!============================================= +! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp +!============================================================================== ! 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. & @@ -140,7 +156,7 @@ subroutine ugwpv1_gsldrag_init ( & return end if - +! if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only @@ -149,6 +165,7 @@ subroutine ugwpv1_gsldrag_init ( & errflg = 1 return endif +! if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag @@ -159,7 +176,57 @@ subroutine ugwpv1_gsldrag_init ( & errflg = 1 return endif - if (is_initialized) return +!========================== +! +! initialize ugwp_common +! con_pi, con_rerth, con_p0, con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt +! +!========================== + + pi = con_pi + arad = con_rerth + p0s = con_p0 + grav = con_g + omega1= con_omega + cpd = con_cp + rd = con_rd + rv = con_rv + fv = con_fvirt + + grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav + rdi = 1.0 / rd ; rcpd = 1./cpd; rcpd2 = 0.5/cpd + gor = grav/rd + gr2 = grav*gor + grcp = grav*rcpd + gocp = grcp + rcpdl = cpd*rgrav + grav2cpd = grav*grcp + + pi2 = 2.*pi ; pih = .5*pi + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + + bnv2min = (pi2/1800.)*(pi2/1800.) + bnv2max = (pi2/30.)*(pi2/30.) + dw2min = 1.0 + velmin = sqrt(dw2min) + minvel = 0.5 + + omega2 = 2.*omega1 + omega3 = 3.*omega1 + + hpscale = 7000. ; hpskm = hpscale*1.e-3 + rhp = 1./hpscale + rhp2 = 0.5*rhp; rh4 = 0.25*rhp + rhp4 = rhp2 * rhp2 + khp = rhp* rd/cpd + mkzmin = pi2/80.0e3 + mkz2min = mkzmin*mkzmin + mkzmax = pi2/500. + mkz2max = mkzmax*mkzmax + cdmin = 2.e-2/mkzmax + + rcpdt = rcpd/dtp if ( do_ugwp_v1 ) then call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & @@ -177,7 +244,9 @@ subroutine ugwpv1_gsldrag_init ( & print *, ' ccpp: ugwpv1_gsldrag_init ' endif + + is_initialized = .true. @@ -238,7 +307,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & - con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & +! con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & nmtvr, hprime, oc, theta, sigma, gamma, elvmax, clx, oa4, & varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & rain, br1, hpbl, kpbl, slmsk, & @@ -252,32 +321,31 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & lprnt, ipr, errmsg, errflg) - -! old data: jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & -! cap: dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf -! ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside ! -! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta -! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 -! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 -!######################################################################## -![ccpp-table-properties] -! name = GFS_interstitial_type -! type = ddt +! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta +! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" !######################################################################## -! -! + +! + + use ugwp_common, only : con_pi => pi, con_g => grav, con_rd => rd, & + con_rv => rv, con_cp => cpd, con_fv => fv, & + con_rerth => arad, con_omega => omega1, rgrav + implicit none -! Preference use (im,levs) rather than (:,:) to avoid memory-leaks -! order description control-logical -! other in-variables -! out-variables -! local-variables -! unified diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 +! Preference use (im,levs) rather than (:,:) to avoid memory-leaks +! that found in Nov-Dec 2020 +! order array-description control-logical +! other in-variables +! out-variables +! local-variables +! +! unified GSL and CIRES diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 ! ! ! interface variables @@ -298,9 +366,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd integer, intent(in) :: kdt, jdat(8) ! SSO parameters and variables - integer, intent(in) :: gwd_opt + integer, intent(in) :: gwd_opt !gwd_opt and nmtvr are "redundant" controls integer, intent(in) :: nmtvr - real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! in gsl_drag + real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! for gsl_drag real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma @@ -311,13 +379,13 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(in), dimension(im, 4) :: oa4ss,ol4ss !===== -!ccpp-style passing constants +!ccpp-style passing constants, I prefer to take them out from the "call-subr" list !===== - 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) :: con_g, con_omega, con_pi, con_cp, con_rd, & +! con_rv, con_rerth, con_fvirt ! grids - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area ! State vars + PBL/slmsk +rain @@ -392,9 +460,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! switches that activate impact of OGWs and NGWs ! integer :: nmtvr_temp - - 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 @@ -419,13 +485,12 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! for all oro-suites can uze geo-meters having "hpbl" ! - inv_g = 1./con_g ! ! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust ! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" ! - zmeti = phii*inv_g - zmet = phil*inv_g + zmeti = phii* rgrav + zmet = phil* rgrav !=============================================================== ! ORO-diag @@ -452,8 +517,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. !=============================================================== -! Accumulated tendencies due to 3-SSO schemes (all ORO-physics) -! ogw + obl +oss +ofd ..... no explicit "lee wave trapping" +! diag tendencies due to all-SSO schemes (ORO-physics) +! ogw + obl + oss + ofd ..... no explicit "lee wave trapping" !=============================================================== do k=1,levs do i=1,im @@ -464,25 +529,18 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo ! -! ------------------ -! -! Also zero all ORO diag-c arrays to avoid "special ifs and zeros" -! like old GFS-ORO gwdps_run has limited diagnostics -! -! ------------------ - ! 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 & .or. do_ugwp_v1_w_gsldrag) then ! -! the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : +! to do: the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : ! ! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd ! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol ! dusfcg, dvsfcg -! gsd_diss_ht_opt =0 => Pdtdt = bl+ls +(Pdtdt=0) +! ! call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & ugrs,vgrs,tgrs,q1, & @@ -494,21 +552,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dusfcg, dvsfcg, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_osscol, dv_osscol, du_ofdcol, dv_ofdcol, & - slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & - con_fvirt,con_pi,lonr, & + slmsk,br1,hpbl, con_g,con_cp,con_rd,con_rv, & + con_fv, con_pi, lonr, & 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) ! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol ! - if (kdt <= 2 .and. me == master) then - print *, ' unified drag_suite_run ', kdt - print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 - print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 - +! if (kdt <= 2 .and. me == master) then +! print *, ' unified drag_suite_run ', kdt +! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! ! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 - +! ! if (gwd_opt == 22 .or. gwd_opt == 33) then ! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 ! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 @@ -519,7 +577,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 ! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 ! endif - endif +! endif else ! @@ -539,8 +597,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & - con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & - con_rerth, con_fvirt,xlat_d, sinlat, coslat, area, & + xlat_d, sinlat, coslat, area, & cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & sigma, gamma, elvmax, sgh30, kpbl, ugrs, & vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & @@ -553,21 +610,20 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms ! ! - if (kdt <= 2 .and. me == master) then +! if (kdt <= 2 .and. me == master) then +! +! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr +! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! endif - print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr - print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 - print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 - print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 - print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 - print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 - endif - -! pdudt = 0.0*pdudt ; pdvdt = 0.0*pdvdt ; pdtdt = 0. end if ! -! GFS-style diag dt3dt(:.:, 1:14) +! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections ! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs @@ -591,14 +647,11 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !================================================================== ! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) ! -! updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs +! 2020 updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs !================================================================== - call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) -! if (me == master) then -! print *, ' ugwpv1 forcing ', maxval(tau_ngw), minval(tau_ngw) -! print *, ' ugwpv1 forcing tamp_mpa ', tamp_mpa -! endif + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) + y4 = jdat(1); month = jdat(2); day = jdat(3) ! ! hour = jdat(5) @@ -616,23 +669,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & tau_ngw, 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, & dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) - - - if (me == master .and. kdt <= 2) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' +! +! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt +! +! if (me == master .and. kdt <= 2) then +! print * +! write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' ! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - - print *, ' ugwp_v1 ', kdt - print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 - print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 - print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 - - - endif +! print * +! +! print *, ' ugwp_v1 ', kdt +! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 +! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 +! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 +! endif end if ! do_ugwp_v1 @@ -657,10 +708,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dvdt_gw = Pdvdt +dvdt_ngw dtdt_gw = Pdtdt +dtdt_ngw kdis_gw = Pkdis +kdis_ngw -! -! add to previous phys-tendencies -! ?-accumulation of GFS ( pbl + gw =0 rf should be taken out from physics, inside FV3-dycore) - +! +! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) +! dudt = dudt + dudt_ngw dvdt = dvdt + dvdt_ngw dtdt = dtdt + dtdt_ngw diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 73d717f78..1cfec2104 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -64,6 +64,8 @@ units = none dimensions = (8) 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 @@ -142,6 +144,60 @@ kind = kind_phys 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_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_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 [do_ugwp] standard_name = do_ugwp long_name = flag to activate CIRES UGWP @@ -445,78 +501,6 @@ 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_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 - 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_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) - units = none - dimensions = () - 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 From a5547cb6785de3c990a62bb3ee5aea5fa32a93be Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 26 Jan 2021 10:50:39 -0700 Subject: [PATCH 06/16] Fix formatting in physics/GFS_phys_time_vary.fv3.F90 --- physics/GFS_phys_time_vary.fv3.F90 | 48 ++++++++++++++++-------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 04f191fdf..b0f88695b 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -81,7 +81,6 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) - logical, intent(in) :: do_ugwp_v1 real(kind_phys), intent(inout) :: ddy_j1tau(:), ddy_j2tau(:) integer, intent(inout) :: jindx1_tau(:), jindx2_tau(:) @@ -108,7 +107,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & -!$OMP shared (do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau) & +!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & !$OMP private (ix,i,j) !$OMP sections @@ -185,11 +184,13 @@ subroutine GFS_phys_time_vary_init ( ! No consistency check needed for in/ccn data, all values are ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP section + +!$OMP section !> - Call tau_amf dats for ugwp_v1 - if (do_ugwp_v1) then - call read_tau_amf(me, master, errmsg, errflg) - endif + if (do_ugwp_v1) then + call read_tau_amf(me, master, errmsg, errflg) + endif + !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") @@ -224,12 +225,14 @@ subroutine GFS_phys_time_vary_init ( jindx2_ci, ddy_ci, xlon_d, & iindx1_ci, iindx2_ci, ddx_ci) endif + !$OMP section !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs if (do_ugwp_v1) then call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & ddy_j1tau, ddy_j2tau) endif + !$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 @@ -292,7 +295,7 @@ subroutine GFS_phys_time_vary_timestep_init ( tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & - do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -316,19 +319,17 @@ subroutine GFS_phys_time_vary_timestep_init ( real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 real(kind_phys), intent(inout) :: rann(:,:) - + logical, intent(in) :: do_ugwp_v1 integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) - real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) - real(kind_phys), intent(inout) :: tau_amf(:) - + real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) + real(kind_phys), intent(inout) :: tau_amf(:) + ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) - logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & @@ -337,7 +338,7 @@ subroutine GFS_phys_time_vary_timestep_init ( facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & - snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -431,13 +432,14 @@ subroutine GFS_phys_time_vary_timestep_init ( iindx2_ci, ddx_ci, & levs, prsl, in_nm, ccn_nm) endif - + !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that resolve GW-activ if (do_ugwp_v1) then - call tau_amf_interp(me, master, im, idate,fhour, & - jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf) + call tau_amf_interp(me, master, im, idate, fhour, & + jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau, tau_amf) endif - + !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN @@ -512,12 +514,12 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (allocated(ciplin) ) deallocate(ciplin) if (allocated(ccnin) ) deallocate(ccnin) if (allocated(ci_pres) ) deallocate(ci_pres) - - ! Deallocate UGWP-input arrays - if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) - if (allocated (tau_limb)) deallocate (tau_limb) + + ! Deallocate UGWP-input arrays + if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) + if (allocated (tau_limb)) deallocate (tau_limb) if (allocated (days_limb)) deallocate(days_limb) - + is_initialized = .false. end subroutine GFS_phys_time_vary_finalize From 2b4489a9a9a8a90bcf8e06f725e625da3f0bd0af Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Thu, 28 Jan 2021 13:32:21 -0500 Subject: [PATCH 07/16] compiling all 3 GW suites --- physics/cires_orowam2017.f | 57 +- physics/cires_ugwp.F90 | 29 +- physics/cires_ugwp.meta | 5 +- physics/cires_ugwp_initialize.F90 | 317 +------- physics/cires_ugwp_initialize_v1.F90 | 805 -------------------- physics/cires_ugwp_module.F90 | 473 +----------- physics/cires_ugwp_module_v1.F90 | 672 ----------------- physics/cires_ugwp_ngw_utils.F90 | 73 -- physics/cires_ugwp_orolm97_v1.F90 | 1008 ------------------------- physics/cires_ugwp_solv2_v1_mod.F90 | 829 -------------------- physics/cires_ugwp_solvers.F90 | 664 ---------------- physics/cires_ugwp_triggers.F90 | 483 +----------- physics/cires_ugwp_triggers_v1.F90 | 584 -------------- physics/cires_ugwp_utils.F90 | 152 ---- physics/cires_ugwpv1_triggers.F90 | 36 - physics/cires_vert_lsatdis.F90 | 524 ------------- physics/cires_vert_orodis.F90 | 1018 ------------------------- physics/cires_vert_orodis_v1.F90 | 1047 -------------------------- physics/cires_vert_wmsdis.F90 | 425 ----------- physics/ugwp_driver_v0.F | 678 +---------------- physics/ugwpv1_gsldrag.F90 | 30 +- physics/unified_ugwp.F90 | 136 +--- physics/unified_ugwp.meta | 51 +- 23 files changed, 180 insertions(+), 9916 deletions(-) delete mode 100644 physics/cires_ugwp_initialize_v1.F90 delete mode 100644 physics/cires_ugwp_module_v1.F90 delete mode 100644 physics/cires_ugwp_ngw_utils.F90 delete mode 100644 physics/cires_ugwp_orolm97_v1.F90 delete mode 100644 physics/cires_ugwp_solv2_v1_mod.F90 delete mode 100644 physics/cires_ugwp_solvers.F90 delete mode 100644 physics/cires_ugwp_triggers_v1.F90 delete mode 100644 physics/cires_ugwp_utils.F90 delete mode 100644 physics/cires_vert_lsatdis.F90 delete mode 100644 physics/cires_vert_orodis.F90 delete mode 100644 physics/cires_vert_orodis_v1.F90 delete mode 100644 physics/cires_vert_wmsdis.F90 diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f index 4170a3d79..c20f98f42 100644 --- a/physics/cires_orowam2017.f +++ b/physics/cires_orowam2017.f @@ -4,7 +4,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & sinlat, xlatd, taup, taud, pkdis) ! USE MACHINE , ONLY : kind_phys - use ugwp_common , only : grav, omega2 + use ugwp_common_v0 , only : grav, omega2 ! implicit none @@ -121,7 +121,7 @@ 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,:), + call oro_meanflow_v0(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)) @@ -275,10 +275,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_v0(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_v0 , only : grav, rgrav, rdi, velmin, dw2min implicit none integer :: nz, nzi @@ -336,4 +336,51 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, rhoi(k) = rhoi(k-1)*.5 dzi(k) = dzi(k-1) - end subroutine oro_meanflow + end subroutine oro_meanflow_v0 + + subroutine ugwpv0_tofd1d(levs, sigflt, elvmax, zsurf, + & zpbl, u, v, zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common_v0 , only : rcpd2 + use ugwpv0_oro_init, only : n_tofd, const_tofd, ze_tofd + use ugwpv0_oro_init, only : 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 + real(kind_phys), dimension(levs) :: epstofd, krf_tofd +! +! locals +! + integer :: i, k + real(kind_phys) :: sghmax = 5. + real(kind_phys) :: sgh2, ekin, zdec, rzdec, umag, zmet + real(kind_phys) :: 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 ugwpv0_tofd1d diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 21b331041..672a2ac81 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -14,7 +14,7 @@ module cires_ugwp use machine, only: kind_phys - use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run @@ -77,7 +77,7 @@ subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return if (do_ugwp .or. cdmbgwd(3) > 0.0) then - call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + call cires_ugwpv0_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 @@ -120,7 +120,7 @@ subroutine cires_ugwp_finalize(errmsg, errflg) if (.not.is_initialized) return - call cires_ugwp_mod_finalize() + call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -293,7 +293,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr 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) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -365,27 +365,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr 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, qgrs(:,:,1), & - 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 diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index d7d7da286..887280612 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -1,8 +1,9 @@ [ccpp-table-properties] name = cires_ugwp type = scheme -# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp! - dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90,cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90,cires_vert_wmsdis.F90,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F +# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_initialize.F90 b/physics/cires_ugwp_initialize.F90 index fbcc1d205..e2f7afd7b 100644 --- a/physics/cires_ugwp_initialize.F90 +++ b/physics/cires_ugwp_initialize.F90 @@ -1,41 +1,11 @@ !=============================== ! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) +! initialization of ugwp_common_v0 +! init gw-solvers (1,2) .. no UFS-funds for (3,4) tests ! init gw-source specifications ! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values - - -! module oro_state - -! integer, parameter :: kind_phys=8 -! integer, parameter :: nvaroro=14 -! real (kind=kind_phys), allocatable :: oro_stat(:, :) -! contains - -! subroutine fill_oro_stat(nx, oc, oa4, clx4, theta, gamm, sigma, elvmax, hprime) - -! real (kind=kind_phys),dimension(nx) :: oc, theta, gamm, sigma, elvmax, hprime -! real(kind=kind_phys),dimension(nx,4) :: oa4, clx4 -! integer :: i -! do i=1, nx -! oro_stat(i,1) = hprime(i) -! oro_stat(i,2) = oc(i) -! oro_stat(i,3:6) = oa4(i,1:4) -! oro_stat(i,7:10) = clx4(i,1:4) -! oro_stat(i,11) = theta(i) -! oro_stat(i,12) = gamm(i) -! oro_stat(i,13) = sigma(i) -! oro_stat(i,14) = elvmax(i) -! enddo -! end subroutine fill_oro_stat - -! end module oro_state - - module ugwp_common +!=============================== + module ugwp_common_v0 ! use machine, only: kind_phys use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & @@ -45,7 +15,7 @@ module ugwp_common real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & rdi = 1.0d0/rd, & - gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & + gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & pi2 = pi + pi, omega1 = pi2/86400.0, & omega2 = omega1+omega1, & @@ -53,7 +23,7 @@ module ugwp_common dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) - end module ugwp_common + end module ugwp_common_v0 ! ! !=================================================== @@ -61,7 +31,7 @@ end module ugwp_common !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) + subroutine init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) implicit none integer :: levs @@ -111,51 +81,20 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) kvg(k) = kvg(k-1) ktg(k) = ktg(k-1) ! - end subroutine init_global_gwdis -! -! - subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none + end subroutine init_global_gwdis_v0 - 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 +! ugwpv0_oro_init ! !========================================================================= - module ugwp_oro_init + module ugwpv0_oro_init - use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common_v0, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi implicit none ! @@ -230,7 +169,7 @@ module ugwp_oro_init contains ! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + subroutine init_oro_gws_v0(nwaves, nazdir, nstoch, effac, & lonr, kxw, cdmbgwd ) ! ! @@ -270,195 +209,10 @@ subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & !.................................................................... ! ! 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 + end subroutine init_oro_gws_v0 ! - 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 module ugwpv0_oro_init !=============================== end of GW sources ! ! init specific gw-solvers (1,2,3,4) @@ -468,7 +222,7 @@ end module ugwp_okw_init ! Part -3 init wave solvers !=============================== - module ugwp_lsatdis_init + module ugwpv0_lsatdis_init implicit none integer :: nwav, nazd @@ -478,7 +232,7 @@ module ugwp_lsatdis_init ! contains - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_lsatdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) implicit none ! @@ -508,14 +262,14 @@ subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb eff = effac endif ! - end subroutine initsolv_lsatdis + end subroutine initsolv_lsatdis_v0 ! - end module ugwp_lsatdis_init + end module ugwpv0_lsatdis_init ! ! - module ugwp_wmsdis_init + module ugwpv0_wmsdis_init - use ugwp_common, only : pi, pi2 + use ugwp_common_v0, only : pi, pi2 implicit none real, parameter :: maxdudt = 250.e-5 @@ -539,8 +293,6 @@ module ugwp_wmsdis_init real, parameter :: zfluxglob= 3.75e-3 real , parameter :: nslope=1 ! the GW sprctral slope at small-m -! 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 @@ -563,11 +315,8 @@ module ugwp_wmsdis_init real, allocatable :: zcosang(:), zsinang(:) contains !============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_wmsdis_v0(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: @@ -680,25 +429,7 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, print * endif - - end subroutine initsolv_wmsdis + end subroutine initsolv_wmsdis_v0 ! -! 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 - + end module ugwpv0_wmsdis_init diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 deleted file mode 100644 index 4258680ea..000000000 --- a/physics/cires_ugwp_initialize_v1.F90 +++ /dev/null @@ -1,805 +0,0 @@ -!=============================== -! 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_v1 -! -! 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_v1 -! -! -!=================================================== -! -!Part-1 init => wave dissipation + RFriction -! -!=================================================== - subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - pa_rf, tau_rf, me, master) - - - implicit none - integer , intent(in) :: me, master - integer , intent(in) :: levs - 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 -! -!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 - real :: pih - - pih = 0.5*con_pi - - 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_v1 -! -! - subroutine rf_damp_init_v1(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_v1 -! ======================================================================== -! Part 2 - sources -! wave sources -! ======================================================================== -! -! ugwp_oro_init_v1 -! -!========================================================================= - module ugwp_oro_init_v1 - - 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 -! -! 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_v1" => 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_v1 -! ========================================================================= -! -! ugwp_conv_init_v1 -! -!========================================================================= - module ugwp_conv_init_v1 - - 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, & - 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 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - 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)" -! - 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(con_pi, nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init_v1 -!========================================================================= -! -! ugwp_fjet_init_v1 -! -!========================================================================= - - module ugwp_fjet_init_v1 - 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, & - con_pi, lonr, kxw) - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - 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(con_pi, nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init_v1 -! -!========================================================================= -! -! - module ugwp_okw_init_v1 -!========================================================================= - 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, & - con_pi, lonr, kxw) - - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - 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(con_pi, nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init_v1 - -!=============================== end of GW sources -! -! init specific gw-solvers (1,2,3,4) -! - -!=============================== -! Part -3 init wave solvers -!=============================== - - module ugwp_lsatdis_init_v1 - 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_v1 -! -! - module ugwp_wmsdis_init_v1 - - 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 - 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_v1 -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis_v1 - implicit none - end subroutine init_dspdis_v1 - - subroutine init_adodis_v1 - implicit none - end subroutine init_adodis_v1 - diff --git a/physics/cires_ugwp_module.F90 b/physics/cires_ugwp_module.F90 index 51c297237..620386ead 100644 --- a/physics/cires_ugwp_module.F90 +++ b/physics/cires_ugwp_module.F90 @@ -1,17 +1,12 @@ ! -module cires_ugwp_module +module cires_ugwpv0_module ! ! driver is called after pbl & before chem-parameterizations ! -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! + implicit none logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver @@ -54,7 +49,7 @@ module cires_ugwp_module 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 :: knob_ugwp_version = 0 ! version control had sense under IPD in CCPP=> to SUITES integer :: launch_level = 55 ! namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & @@ -106,16 +101,14 @@ module cires_ugwp_module ! init of cires_ugwp (_init) called from GFS_driver.F90 ! ! ----------------------------------------------------------------------- - subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + subroutine cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & pa_rf_in, tau_rf_in) - 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, ilaunch - use ugwp_lsatdis_init, only : initsolv_lsatdis + use ugwpv0_oro_init, only : init_oro_gws_v0 + use ugwpv0_wmsdis_init, only : initsolv_wmsdis_v0, ilaunch + use ugwpv0_lsatdis_init, only : initsolv_lsatdis_v0 + implicit none integer, intent (in) :: me @@ -132,7 +125,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes real, intent (in) :: pa_rf_in, tau_rf_in -! integer, parameter :: logunit = 6 integer :: ios logical :: exists real :: dxsg @@ -155,8 +147,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & read (nlunit, nml = cires_ugwp_nml) close (nlunit) #endif - - ! ilaunch = launch_level @@ -173,13 +163,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! effective kxw - resolution-aware ! dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh -! -! 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) ) @@ -195,50 +178,22 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! ! Part-1 :init_global_gwdis ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) - call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + call init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) + ! -! Part-2 :init_SOURCES_gws +! Part-2 :init_SOURCES_gws -- only orowaves, but ugwp-v0 is based on gwdps.f of EMC ! ! ! call init-solver for "stationary" multi-wave spectra and sub-grid oro ! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + call init_oro_gws_v0( 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) - !====================== ! Part-3 :init_SOLVERS ! ===================== @@ -247,428 +202,40 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! if (knob_ugwp_solver==1) then ! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_lsatdis_v0(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 - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_wmsdis_v0(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 *, ' VAY-ugwp is initialized ', module_is_initialized - - end subroutine cires_ugwp_mod_init - -! ----------------------------------------------------------------------- -! -! driver of cires_ugwp (_driver) -! called from GFS_physics_driver.F90 -! -! ----------------------------------------------------------------------- -! call cires_ugwp_driver & -! (im, levs, dtp, kdt, me, lprnt, Model%lonr, & -! Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & -! Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & -! Statein, delp_gws, Oro_stat, & -! dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & -! Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & -! Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & -! Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & -! Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & -! Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & -! Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & -! Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & -! Diag%du3dt_ogw, Diag%du3dt_tms ) - - subroutine cires_ugwp_driver & - (im, levs, dtp, kdt, me, lprnt, lonr, & - pa_rf, tau_rf, cdmbgwd, xlat, xlatd, sinlat, coslat, & - ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & - delp, orostat, kpbl, & - dusfc, dvsfc, dudt, dvdt, dtdt, kdis, & - axtot, axo, axc, axf, aytot, ayo, ayc, ayf, & - eps_tot, ekdis, trig_okw, trig_fgf, & - dcheat, precip, cld_klevs, zmtb, scheat, dlength, cldf, & - taus_sso, taus_ogw, tauf_ogw, tauf_ngw, & - ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb, ugw_axlwb, ugw_axtms ) - -! - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd - use ugwp_common, only: omega2 -! -! - use ugwp_okw_init, only : & - eff_okw, nstokw, nwokw, ch_okwp, nazokw, spf_okwp, xaz_okwp, yaz_okwp - use ugwp_conv_init, only : & - eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv - use ugwp_fjet_init, only : & - eff_fj, nstfj, nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet - -! - implicit none -! - - logical :: lprnt - integer :: me, im, levs, kdt, lonr - real(kind_phys) :: dtp - real(kind_phys) :: pa_rf, tau_rf - real(kind_phys) :: cdmbgwd(2) - - integer, intent(in) :: kpbl(im) - real(kind_phys) :: hpbl(im) - real(kind_phys), intent(in) :: orostat(im, 14) - real(kind_phys), intent(in), dimension(im,levs) :: ugrs, vgrs, & - tgrs, qgrs, prsi, prsl, prslk, phii, phil, delp -! - real(kind_phys), dimension(im) :: xlat, xlatd, sinlat, coslat - real(kind_phys), dimension(im, levs) :: trig_okw, trig_fgf - real(kind_phys), dimension(im) :: precip ! precip-n rates and - integer , dimension(im, 3) :: cld_klevs ! indices fo cloud top/bot/? - real(kind_phys), dimension(im, levs) :: dcheat, scheat ! deep and shal conv heat tend. - - - real(kind_phys), dimension(im) :: dlength ! tail-grid box scale in meters - real(kind_phys), dimension(im) :: cldf ! "bizzard" old cgwd-tuning knobs dimensionless -!=================== -! tendency + kdis -!=================== - real(kind_phys), dimension(im, levs) :: dudt, dvdt, dtdt, kdis - real(kind_phys), dimension(im, levs) :: axtot, axo, axc, axf - real(kind_phys), dimension(im, levs) :: aytot, ayo, ayc, ayf - real(kind_phys), dimension(im, levs) :: eps_tot, ekdis - -! - real(kind_phys), dimension(im, levs) :: eds_o, kdis_o - real(kind_phys), dimension(im, levs) :: eds_c, kdis_c - real(kind_phys), dimension(im, levs) :: eds_f, kdis_f - real(kind_phys), dimension(im, levs) :: ax_rf, ay_rf, eps_rf -! -!================================================================================== -! diagnostics for OGW & NGW + SSO effects axmtb, axlwb, axtms -!================================================================================== - real(kind_phys), dimension(im) :: dusfc, dvsfc - real(kind_phys), dimension(im) :: taus_sso, taus_ogw, tauf_ogw, tauf_ngw - real(kind_phys), dimension(im) :: ugw_zmtb, ugw_zlwb, ugw_zogw - real(kind_phys), dimension(im, levs) :: ugw_axmtb,ugw_axlwb, ugw_axtms - real(kind_phys), dimension(im, levs) :: tauz_ogw, tauz_ngw, wtauz - -! -! knob_ugwp_source=[ 1, 1, 1, 0 ] -! oro conv nst imbal-okw -! locals -! - integer :: i, j, k, istype, ido -! -! internal diagnostics for oro-waves, lee waves, and mtb : -! - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw ! GW-launch levels in "meters" -! - real(kind_phys), dimension(im) :: fcor, c2f2 -! -! three sources with different: a) spectra-content/azimuth; b) efficiency ;c) spectral shape -! - real(kind_phys), dimension(im) :: taub_con, taub_fj, taub_okw - integer , dimension(im) :: klev_okw, klev_fj, klev_con - integer , dimension(im) :: if_okw, if_con, if_fj - integer :: nf_okw, nf_con, nf_fj -! - dudt = 0. - dvdt = 0. - dtdt = 0. - kdis = 0. - axo = 0. ; axc = 0. ; axf = 0. - ayo = 0. ; ayc = 0. ; ayf = 0. - eds_o = 0. ; kdis_o = 0. ; eds_f = 0. ; kdis_f = 0. ; eds_c = 0. ; kdis_c = 0. - ax_rf = 0. ; ay_rf = 0. ; eps_rf = 0 - - hpbl(:) = 2000. ! hpbl (1:im) = phil(1:im, kpbl(1:im)) -! - - do i=1, im - fcor(i) = omega2*sinlat(i) - c2f2(i) = fcor(i)*fcor(i)/(kxw*kxw) - enddo - -! i=im -! print *, i, fcor(i), 6.28e-3/kxw, sqrt(c2f2(i)) -! print *, maxval(statein%prsl/statein%tgrs)/287. , ' density ' - -! -! -! What can be computed for ALL types of GWs? => -! "Br-Vi frequency"with "limits" in case of "conv-unstable" layers -! Background dissipation: Molecular + Eddy -! Wind projections may differ from GW-sources/propagation azimuths -! - do istype=1, size(knob_ugwp_source) - - ido = knob_ugwp_source(istype) ! 0 or 1 off or active - - ugwp_azdir = knob_ugwp_azdir(istype) - ugwp_stoch = knob_ugwp_stoch(istype) - ugwp_nws = knob_ugwp_wvspec(istype) - ugwp_effac = knob_ugwp_effac(istype) - -! -! oro-gw effects -! - if (ido == 1 .and. istype ==1 ) then -! -! 1. solve for OGW effects on the mean flow -! 2. all parts of ORO effexra inside: MTB TOFD LeeWB OGW-drag -! - call ugwp_oro(im, levs, dtp, kdt, me, lprnt, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - orostat, hpbl, axo, ayo, eds_o, kdis_o, & - dusfc, dvsfc, dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, & - dusfc_lwb, dvsfc_lwb, zmtb, zlwb, zogw,tauf_ogw,tauz_ogw,& - ugw_axmtb,ugw_axlwb, ugw_axtms) -! -! taus_sso, taus_ogw, tauz_ogw, tauz_ngw, tauf_ogw, tauf_ngw, & -! ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb,ugw_axlwb, ugw_axtms -! collect column-integrated "dusfc, dvsfc" only for oro-waves -! - taus_sso = dusfc_mb + dusfc_lwb + dusfc_ogw - taus_ogw = dusfc_ogw - ugw_zmtb = zmtb - ugw_zlwb = zlwb - ugw_zogw = zogw -! tauz_ogw/tauf_ogw => output -! ugwp_azdir, ugwp_stoch, ugwp_nws ..... "multi-wave + stochastic" -! -! stationary gw-mode ch=0, with "gw_solver_linsat" -! compute column-integrated "dusfc, dvsfc" only for oro-waves -! - dudt = dudt + axo * ugwp_effac - dvdt = dvdt + ayo * ugwp_effac - dtdt = dtdt + eds_o * ugwp_effac - kdis = kdis + kdis_o* ugwp_effac -! print *, ' ido istype ORO=1 ', ido, istype, ' ugwp_oro as a solver ' - endif - - if (ido == 1 .and. istype ==2 ) then -! -! convective gw effects -! -! 1. specify spectra + forcing nstcon, nwcon, ch_conv, nazcon, spf_conv -! - call get_spectra_tau_convgw & - (nwcon, im, levs, dcheat, scheat, precip, cld_klevs, & - xlatd, sinlat, coslat, taub_con, klev_con, if_con, nf_con) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_con > 0) then - - klev_con(:) = 52 ! ~5 km -! -!eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv, & - fcor, c2f2, ugrs, vgrs, tgrs, qgrs, prsi, delp, & - prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) - - - if (knob_ugwp_solver == 2) then -! print *, ' before CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) -! print *, ' after ido istype CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - endif - - dudt = dudt + axc * ugwp_effac - dvdt = dvdt + ayc * ugwp_effac - dtdt = dtdt + eds_c * ugwp_effac - kdis = kdis + kdis_c * ugwp_effac - - tauz_ngw = wtauz - - endif - - endif - - if (ido == 1 .and. istype ==3 ) then -! -! nonstationary gw effects -! -! 1. specify spectra + forcing -! - call get_spectra_tau_nstgw (nwfj, im, levs, & - trig_fgf, xlatd, sinlat, coslat, taub_fj, klev_fj, if_fj, nf_fj) -! -! 2. solve for GW effects on the mean flow -! - print *, ' tau_nstgw nf_fj-GW triggers ', nf_fj, ' ugwp_solver = ', knob_ugwp_solver - if ( nf_fj > 0) then - - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - print *, ' ido istype for FJ 1-4 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - - endif - endif -! print *, ' ido istype for okw 1-4 ', ido, istype - if (ido == 1 .and. istype == 4 ) then -! -! nonstationary gw effects due to both "convection +fronts/jets " = imbalance of rs-flow -! -! 1. specify spectra + forcing -! - call get_spectra_tau_okw (nwokw, im, levs,& - trig_okw, xlatd, sinlat, coslat, taub_okw, klev_okw, if_okw, nf_okw) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_okw > 0) then -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - endif - endif -! -! broad gw-spectra -! - 356 continue - enddo -! -! gw-diag only -! - axtot = dudt - aytot = dvdt - eps_tot = dtdt - -! -! optional rf-damping -! - if (do_rfdamp) then -! -! - call rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, ugrs, vgrs, ax_rf, ay_rf, eps_rf) -! -! gw-diag only + rf-damping ..... now orchestrate it with FV3-dycore RF-damping -! - do k=levs_rf, levs - - dudt(:,k) = dudt(:,k) + ax_rf(:,k) - dvdt(:,k) = dvdt(:,k) + ay_rf(:,k) - dtdt(:,k) = dtdt(:,k) + eps_rf(:,k) - - enddo - - endif -!================================================================================ -! To update U-V-T STATE by [dudt dvdt dtdt kdis+rf] => Solve 3-diag VD-equation -!================================================================================ -! to do for fv3wam=> -! joint eddy+molecular viscosity/conductivity/diffusion -! requires "dqdt" + dudt_vis, dvdt_vis. dtdt_cond - -! print *, ' cires_ugwp_driver +++++++++++++++++ ' -! - end subroutine cires_ugwp_driver - - -!============================================= - - - 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 - + end subroutine cires_ugwpv0_mod_init ! ! ----------------------------------------------------------------------- ! finalize of cires_ugwp (_finalize) ! ----------------------------------------------------------------------- - - subroutine cires_ugwp_mod_finalize + subroutine cires_ugwpv0_mod_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 arrays employed in V0 ! deallocate( kvg, ktg ) deallocate( krad, kion ) deallocate( zkm, pmb ) deallocate( rfdis, rfdist) - end subroutine cires_ugwp_mod_finalize + end subroutine cires_ugwpv0_mod_finalize ! - end module cires_ugwp_module + end module cires_ugwpv0_module diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 deleted file mode 100644 index fd41d8175..000000000 --- a/physics/cires_ugwp_module_v1.F90 +++ /dev/null @@ -1,672 +0,0 @@ - -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_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 - 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,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 - 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 :: 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 - -! - 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_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, 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 -! - 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_v1, only : initsolv_lsatdis - - - 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 - 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, 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 - logical :: exists - real :: dxsg - - integer :: ncid, iernc, vid, dimid, status - integer :: k - integer :: ddd_ugwp, curday_ugwp - 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) -! - 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) -! - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - - 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_v1 -! - 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 -! - -! -! 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_v1 ' - 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), & - 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), & - 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), & - con_pi, con_rerth, 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(errmsg,'(*(a))') "Cannot open file_limb_tab data-file ", & - trim(ugwp_taufile) - errflg = 1 - return - 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(errmsg,'(*(a))') "Cannot open qbofile data-file ", & - trim(ugwp_qbofile) - errflg = 1 - return - 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 deleted file mode 100644 index 4b2a19884..000000000 --- a/physics/cires_ugwp_ngw_utils.F90 +++ /dev/null @@ -1,73 +0,0 @@ -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 deleted file mode 100644 index fd692a825..000000000 --- a/physics/cires_ugwp_orolm97_v1.F90 +++ /dev/null @@ -1,1008 +0,0 @@ -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, 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, & - 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_v1, only : dw2min, velmin - - use ugwp_oro_init_v1, 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_v1, only : kxw, max_kdis, max_axyz - - use cires_orowam2017, only : oro_wam_2017 - - use cires_vert_orodis_v1, 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), 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 - - 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 , sigma, gamma, & - 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 - - 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 -! - 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 -! -! initialize gamma and sigma - gamma(:) = gammad(:) - sigma(:) = sigmad(:) -! - 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 -! - 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, & - grav, con_omega, rd, & - 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, cpd, 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 deleted file mode 100644 index 46a5fb833..000000000 --- a/physics/cires_ugwp_solv2_v1_mod.F90 +++ /dev/null @@ -1,829 +0,0 @@ -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, & - grav, cpd, rd, rv, omega, pi, fv, & - 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_v1,only : krad, kvg, kion, ktg - - use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - - 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, & - 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 - - real ,intent(in) :: grav, cpd, rd, rv, omega, pi, fv -! -! -! 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 :: 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 - 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 - 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(:) - - 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 = 2*omega * 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_solvers.F90 b/physics/cires_ugwp_solvers.F90 deleted file mode 100644 index 6736daf6a..000000000 --- a/physics/cires_ugwp_solvers.F90 +++ /dev/null @@ -1,664 +0,0 @@ -! GW SOLVERS: -!=========== SOLVER_ORODIS; SOLVER_WMSDIS, SOLVER_LSATDIS -! + RF_DAMP if it is needed along with ugwp_tofd -!=========== -! Note in contrast to dycore vertical indices: surface=1 top=levs -! -! Collection of main friction-GWD solvers -! -! subroutine ugwp_oro -! -! subroutine gw_solver_linsatdis -! subroutine gw_solver_wmsdis -! subroutine rf_damp -! -! =========== -! -! - subroutine ugwp_oro(im, levs, dtp, kdt,me, lprnt, fcor, c2f2, & - u, v, tkin, pint, delp, pmid, pexner, gzint, gzmid, orostat, & - hpbl, axz, ayz, edis, kdis, dusfc, dvsfc, & - dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, dusfc_lwb, dvsfc_lwb, & - zmtb, zlwb, zogw, tauf_ogw, tauz_ogw, axmtb, axlwb, axtms ) -!---------------------------------------------------------------------- -! COORDE-output: 6-hour inst: U, V, T, PMSL, PS, HT (ounce) -! 3D 6-hr aver: DYN-U, SSO-U, PBL-U, AF-U1.... -! 2D 6-hr aver: tau_SSO, tau_GWD, tau_BL; & -! tau_sso = tau_mtb + tau_tofd + tau_lwb +tau_ogw -! ZM 6-hr aver: tau_RES = PS*dH/dx -zonal mean -! Experiments: Midlat 80-200km -! LR_CTL; ; LR_NOSSO with TOFD/TMS; -! LR_NOGWD (MTN+TOFD); LR_GWD4 --- 4 times taub -!---------------------------------------------------------------------- - use machine , only : kind_phys - use ugwp_oro_init, only : cdmb, cleff, sigfac, hncrit, hpmin, hminmt - use ugwp_oro_init, only : gamm_std, sigma_std - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - - - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - - implicit none - logical :: lprnt - integer :: im, levs - integer :: me - integer :: kdt - real(kind_phys) :: dtp - real(kind_phys), dimension(im) :: hpbl ! pbl-height in meters - real(kind_phys), dimension(im) :: fcor, c2f2 - real(kind_phys), dimension(im, 14) :: orostat - real(kind_phys), dimension(im, levs) :: u, v, tkin, q - - real(kind_phys), dimension(im, levs) :: pmid, pexner, gzmid, delp - real(kind_phys), dimension(im, levs+1) :: pint, gzint - - - real(kind_phys), dimension(im, levs) :: axz, ayz, edis, kdis ! total 6-hr averaged tendencies - real(kind_phys), dimension(im, levs) :: krf2d - real(kind_phys), dimension(im, levs) :: tauz_ogw, axmtb, axlwb, axtms ! 3-sub components axogw = axz-(axmtb+axlwb+axtms) - real(kind_phys), dimension(im) :: tauf_ogw ! total-source momentum flux - - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw - - real(kind_phys), dimension(im) :: dusfc, dvsfc ! total tausfc_sso - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb ! integrated tau_mtb - real(kind_phys), dimension(im) :: dusfc_ogw, dvsfc_ogw ! integrated tau_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb ! integrated tau_lwb - real(kind_phys), dimension(im) :: dusfc_tofd, dvsfc_tofd ! integrated tau_tofd - -! -! mu=hprime gamm=a/b sigma theta -! which stand for the standard deviation, the anisotropy, the slope and the orientation of the orography. -! - real(kind_phys) :: elvmax(im) - real(kind_phys) :: hprime(im) - - real(kind_phys) :: theta !the orienatation, angle - real(kind_phys) :: sigma !the slope dh/dx - real(kind_phys) :: gamm !the anisotropy see ifs-oro - - real(kind_phys) :: oc, oa4(4), clx4(4) !kim & doyle 2005 .... attempt to do TOFD ..? -! - integer, allocatable :: k_elev(:), k_mtb(:), k_ogw(:), k_lee(:), k_tofd(:) - - real(kind_phys) wk(im) - - real(kind_phys) eng0, eng1 -! -! -! - real(kind_phys), dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid1, pex - - real(kind_phys), dimension(levs+1) :: taudz, rhoi, rim_z, pint1, zpi - real(kind_phys), dimension(levs) :: drtau, kdis_oro -! - real (kind_phys) :: elvp, elvpd, dtaux, dtauy - real(kind_phys) :: loss, mtb_fric, mbx, mby - real(kind_phys) :: sigflt - - real(kind_phys) :: zpbl = 2000. ! can be passed from PBL physics as in gwdps.f -! - logical icrilv(im) -! -!---- mountain/oro gravity wave drag +TOFD -! - real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1, epstofd1, krf_tofd1 -! - real(kind=kind_phys), dimension(levs) :: drlee, drmtb, drlow, drogw - real(kind_phys) :: r_cpdt, acc_lim - real(kind_phys), dimension(im) :: tautot, tauogw, taumtb, taulee, taurf - real(kind_phys) :: xn, yn, umag, kxridge, & - tx1, tx2 - real(kind=kind_phys),dimension(levs+1):: tau_src - - integer :: npt, krefj, kdswj, kotr, i, j, k - integer :: ipt(im) - -! -! copy 1D -! - do i=1, im - hprime(i) = orostat(i, 1) - elvmax(i) = orostat(i, 14) -! - tautot(i) = 0.0 - tauogw(i) = 0.0 - taumtb(i) = 0.0 - taulee(i) = 0.0 - taurf(i) = 0.0 -! - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - dusfc_mb(i) = 0.0 - dvsfc_mb(i) = 0.0 - dusfc_ogw(i) = 0.0 - dvsfc_ogw(i) = 0.0 - dusfc_lwb(i) = 0.0 - dvsfc_lwb(i) = 0.0 - dusfc_tofd(i) = 0.0 - dvsfc_tofd(i) = 0.0 - tauf_ogw(i) = 0.0 -! - zmtb(i) = -99. - zlwb(i) = -99. - zogw(i) = -99. - ipt(i) = 0 - enddo -! print *, maxval(hprime), maxval(elvmax), ' check hprime -elevmax ugwp_oro' -! -! 3-part of oro-effects + ked_oro -! - do k=1, levs - do i=1, im - axz(i,k) = 0.0 - ayz(i,k) = 0.0 - edis(i,k) = 0.0 - kdis(i,k) = 0.0 - krf2d(i,k) = 0.0 - tauz_ogw(i,k) = 0.0 - axmtb(i:,k) = 0.0 - axlwb(i,k) = 0.0 - axtms(i,k) = 0.0 - enddo - enddo - -! -! optional diag 3-parts of drag: [tx_ogw, tx_mtb, tx_lee] -! -! ----do we have orography for mtb and gwd calculation points ? -! - npt = 0 - do i = 1,im - if ( (elvmax(i) > hminmt) .and. (hprime(i) > hpmin) ) then - npt = npt + 1 - ipt(npt) = i - - endif - enddo - if (npt == 0) return ! no ororgraphy ====> gwd/mb calculation done - -! allocate(iwklm(npt), idxzb(npt), kreflm(npt)) - allocate( k_elev(npt), k_mtb(npt), k_ogw(npt), k_lee(npt), k_tofd(npt)) - do i=1,npt - k_ogw (i) = 2 - k_tofd(i) = 2 - k_lee (i) = 2 - k_mtb(i) = 0 - k_elev(i) = 2 - enddo -! -! controls through: use ugwp_oro_init -! main ORO-loop sigfac = n*sigma = [1.5, 2, 2.5, 4]*hprime -! - - - do i = 1, npt -! - j = ipt(i) - - elvpd = elvmax(j) - elvp = min (elvpd + sigfac * hprime(j), hncrit) - - sigma = orostat(j,13) - gamm = orostat(j,12) - theta = orostat(j,11)*deg_to_rad - - if (sigma == 0.0 ) then - sigma = sigma_std - gamm = gamm_std - theta = 0.0 - endif - - oc = orostat(j,2) - oa4(1) = orostat(j,3) - oa4(2) = orostat(j,4) - oa4(3) = orostat(j,5) - oa4(4) = orostat(j,6) - clx4(1) = orostat(j,7) - clx4(2) = orostat(j,8) - clx4(3) = orostat(j,9) - clx4(4) = orostat(j,10) -! -! do column-based diagnostics "more-efficient" for oro-places -! - - do k=1,levs - up(k) = u(j,k) - vp(k) = v(j,k) - tp(k) = tkin(j,k) - qp(k) = q(j,k) - dp(k) = delp(j,k) - - zpm(k) = gzmid(j,k) * rgrav - pmid1(k) = pmid(j,k) - pex(k) = pexner(j,k) - enddo - do k=1,levs+1 - zpi(k) = gzint(j,k) * rgrav - pint1(k) = pint(j,k) - enddo -! -! elvp- k-index: iwklm k_elvp = index for elvmax + 4*hprime, "elevation index" -! GFS-2017 - do k=1, levs-1 - if (elvp <= zpi(k+1) .and. elvp > zpi(k)) then - k_elev(i) = k+1 !......simply k+1 next interface level - exit - endif - enddo -! if (elvp .ge. 300. ) then -! write(6,333) elvp, zpi(1), elvpd, hprime(j), sigfac, hncrit -! pause -! endif -!333 format(6(3x, F10.3)) -! -! SSO effects: TOFD-drag/friction coefficients can be calculated -! - sigflt = hprime(j)*0.01 ! turb SSo(j) ...small-scale orography < 2-5 km .... - zpbl = hpbl(j) - - call ugwp_tofd1d(levs, sigflt, elvPd, zpi(1), zpbl, up, vp, zpm, & - utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1, levs - krf2d(j,k) = krf_tofd1(k) - axtms(j,k) = utofd1(k) -!------- -! nullify ORO-tendencies -! - drmtb(k) = 0.0 - drlee(k) = 0.0 - drtau(k) = 0.0 - drlow(k) = 0.0 - enddo - -!------- -! -! levels of k_mtb(i)/mtb + kdswj/dwlee + krefj/ogwd inside next "subs" -! zmtb, zlwb, zogw -! drmtb, drlow/drlee, drogw -!------- -! -! mtb : drmtb => 1-st order friction as well as TurbulentOro-Drag -! - call ugwp_drag_mtb( k_elev(i), levs, & - elvpd, elvp, hprime(j), sigma, theta, oc, oa4, clx4, gamm, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, k_mtb(i), drmtb, taumtb(j)) - - axmtb(j,1:levs) = drmtb(1:levs)*up(1:levs) -! -! print * , k_elev(i), k_mtb(i) , taumtb(j)*1.e3, ' k_elev, k_mtb , taumtb ' -! -! tautot = taulee+tauogw + rho*drlee = -d[taulee(z)]/dz -! - - - call ugwp_taub_oro(levs, k_mtb(i), kxw, taumtb(j), fcor(j), & - hprime(j) , sigma, theta, oc, oa4, clx4, gamm, elvp, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, xn, yn, umag, & - tautot(j), tauogw(j), taulee(j), drlee, tau_src, & - kxridge, kdswj, krefj, kotr) - -! print *, k_mtb(i), kxw, taumtb(j), fcor(j),hprime(j), ' af ugwp_taub_oro ' -! print *, kdswj, krefj, kotr, ' kdswj, krefj, kotr ' - - - tauf_ogw(j) = tautot(j) - axlwb(j,1:levs) = drlee(1:levs) - - if ( k_mtb(i) > 0) zmtb(j) = zpi(k_mtb(i))- zpi(1) - if ( krefj > 0) zogw(j) = zpi(krefj) - zpi(1) - if ( kdswj > 0) zlwb(j) = zpi(kdswj) - zpi(1) -! if ( k_mtb(i) > 0 .and. zmtb(j) > zogw(j)) print *, ' zmtb > zogw ', zmtb(j), zogw(j) -! -! tau: tauogw, kxw/kxridge ATTENTION c2f2(j) = fcor(j)*fcor(j)/kxridge/kxridge -! - if ( (krefj > 1) .and. ( abs(tauogw(j)) > 0.) ) then -! - call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & - fcor(j), kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & - xn, yn, umag, drtau, kdis_oro) -! - else - drtau = 0. - endif - - tauz_ogw(j,1:levs) = tau_src(1:levs) - - r_cpdt = rcpd2/dtp -! -! - do k = 1,levs -! -! project to x-dir & y=dir and do diagnostics -! & apply limiters and output separate oro-effects -! - drlow(k) = drtau(k) + drlee(k) - acc_lim = min(abs(drlow(k)), max_axyz) - drlow(k) = sign(acc_lim, drlow(k)) - - dtaux = drlow(k) * xn + utofd1(k) - dtauy = drlow(k) * yn + vtofd1(k) - - eng0 = up(k)*up(k)+vp(k)*vp(k) - eng1 = 0.0 -! - if (k < k_mtb(i) .and. drmtb(k) /= 0 ) then - loss = 1.0 / (1.0+drmtb(k)*dtp) - mtb_fric = drmtb(k)*loss -! - mbx = mtb_fric * up(k) - mby = mtb_fric * vp(k) -! - ayz(j,k) = -mby !+ ayz(j,k) - axz(j,k) = -mbx !+ axz(j,k) -! - eng1 = eng0*loss*loss +eng1 - dusfc(j) = dusfc(j) - mbx * dp(k) - dvsfc(j) = dvsfc(j) - mby * dp(k) - endif -! - ayz(j,k) = dtauy + ayz(j,k) - axz(j,k) = dtaux + axz(j,k) -! - tx1 = u(j,k) + dtaux*dtp - tx2 = v(j,k) + dtauy*dtp - eng1 = tx1*tx1 + tx2*tx2 + eng1 - - dusfc(j) = dusfc(j) + dtaux * dp(k) - dvsfc(j) = dvsfc(j) + dtauy * dp(k) - - edis(j,k) = max(eng0-eng1, 0.0) * r_cpdt !+ epstofd1(k) - kdis(j,k) = min(kdis_oro(k), max_kdis ) - - enddo -! - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) -! -! oro-locations -! - enddo ! ipt - oro-loop .... "fraction of Land" in the grid box - deallocate(k_elev, k_mtb, k_ogw, k_lee, k_tofd ) -! - end subroutine ugwp_oro -! -! - subroutine gw_solver_linsatdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs - integer :: me, kdt, nw, naz, nf_src - real :: dtp - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, & - q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, & - bn2i, bvi, rhoi - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real, dimension(levs+1) :: ked1, tau1 - real :: chm, ss - real, parameter :: dsp = 1./20. - logical :: pfirst=.true. - - save pfirst -128 Format (2x, I4, 4(2x, F10.3)) - -! do i=1, nw -! spf(i) = exp(-Ch(i)*dsp) -! enddo -! ss = sum(spf) -! spf(1:nw) = spf(1:nw)/ss - - if (pfirst ) then - j = 1 - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j) - print * - chm = 0. - do i=1, nw - write(6, 128) i, spf(i), taub_spect(i)*1.e3, ch(i), ch(i)-chm - chm = ch(i) - enddo - - print * - !pause - endif - - do j=1,im - if (if_src(j) == 1) then -! -! compute GW-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! H2O-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) * rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k) * rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j)/rhoi(ksrc) - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' tempi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(u1), minval(u1) , ' ++++ u1 ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(v1), minval(v1) , ' ++++ v1 ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! - call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, & - ch, xaz, yaz, fcor(j), c2f2(j), dp, & - zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, & - ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' rhoi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - endif - - enddo - pfirst = .false. -! -! spectral solver for discrete spectra of GWs in N-azimiths -! Linear saturation with background dissipation -! - end subroutine gw_solver_linsatdis -! - subroutine gw_solver_wmsdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) -! use para_taub, only : tau_ex - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs, me, kdt, nw, naz, nf_src - real :: dtp - - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real,dimension(levs+1) :: ked1, tau1 - real :: tau_ex - -! print *, nf_src, 'nf_src ... gw_solver_wmsdis ' -! print *, if_src, 'if_src ... gw_solver_wmsdis ' - - do j=1,im - if (if_src(j) == 1) then -! -! compute gw-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! h2o-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) *rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k)*rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! -! any extras bkg-arrays -! - ksrc = klev(j) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! more work for spectral setup for different "slopes" -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tau_ex = taub(j) - taub_spect(1:nw) = spf(1:nw)/rhoi(ksrc) *tau_ex ! check it ....*tau_ex(j) - -! -! call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) -! -! print *, ' bf ugwp_wmsdis_naz ksrc', ksrc, zmid(ksrc) - - call ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, tau_ex, ch, xaz, yaz, & - fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, & - rho, ui, vi, ti, kvg, ktg, krad, kion, bn2i, bvi, & - rhoi, ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - -! print *, ' after ugwp_wmsdis_naz ksrc', ksrc, zint(ksrc) - -! subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & -! fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked) - -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - - endif - - enddo -! -! ugwp_wmsdis_naz everything similar to linsat , except spectral saturation -! -! - return - end subroutine gw_solver_wmsdis -! -! - subroutine rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, u, v, ax, ay, eps) - use ugwp_common, only : rcpd2 - - implicit none - - integer :: im, levs, levs_rf - real :: dtp - real, dimension(levs) :: rfdis, rfdist - real, dimension(im, levs) :: u, v, ax, ay, eps - real :: ud, vd, rdtp - integer :: i, k - - rdtp = 1.0 / dtp - - do k= levs_rf, levs - do i=1,im - ud = rfdis(k)*u(i,k) - vd = rfdis(k)*u(i,k) - ax(i,k) = rfdist(k)*u(i,k) - ay(i,k) = rfdist(k)*v(i,k) - eps(i,k) = rcpd2*(u(i,k)*u(i,k) +v(i,k)*v(i,k) -ud*ud -vd*vd) - enddo - enddo - end subroutine rf_damp -! diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index c345a8e85..4a8b97590 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -1,473 +1,5 @@ - 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(im, tau_amp, xlatdeg, tau_gw) + subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -498,9 +30,9 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5_tamp + end subroutine slat_geos5_tamp_v0 - subroutine slat_geos5(im, xlatdeg, tau_gw) + subroutine slat_geos5_v0(im, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -537,9 +69,10 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5 - subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common , only : pi2 + end subroutine slat_geos5_v0 +! + subroutine init_nazdir_v0(naz, xaz, yaz) + use ugwp_common_v0 , only : pi2 implicit none integer :: naz real, dimension(naz) :: xaz, yaz @@ -563,4 +96,4 @@ subroutine init_nazdir(naz, xaz, yaz) xaz(4) = 0.0 yaz(4) =-1.0 !S endif - end subroutine init_nazdir + end subroutine init_nazdir_v0 diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 deleted file mode 100644 index 8cfd57cb7..000000000 --- a/physics/cires_ugwp_triggers_v1.F90 +++ /dev/null @@ -1,584 +0,0 @@ -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, con_pi, earth_r, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - 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 :: 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... -! - deg_to_rad = con_pi/180.0 - 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, & - 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 - 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, con_pi, con_rerth, & - 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 :: con_pi, con_rerth -! - 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, con_pi, con_rerth, & - 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, & - 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 -! - 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, & - 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) -!===================================================================================================== -! 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(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 - 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_ugwp_utils.F90 b/physics/cires_ugwp_utils.F90 deleted file mode 100644 index 63a5b3238..000000000 --- a/physics/cires_ugwp_utils.F90 +++ /dev/null @@ -1,152 +0,0 @@ -! - subroutine um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, bn2, uhm, vhm, bn2hm, rhohm) -! - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - implicit none -! -! mass-averaged variables between klow-ktop -! - integer, intent(in) :: nz, klow, ktop - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: pint, zpi - real, dimension(nz), intent(out) :: bn2 - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp, rhm,dphm - - real, intent(out) :: uhm, vhm, bn2hm, rhohm - - integer :: k -! - dphm = 0.0 !pint(k+1)-pint(k)) - - uhm = 0.0 ! dphm*u1(k) - vhm = 0.0 ! dphm*v1(k) - rhm = 0.0 ! - bn2hm = 0.0 ! -! - do k=klow, ktop - vtj = tp(k) * (1.+fv*qp(k)) - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rhok = rdi * pmid(k) / vtj ! density kg/m**3 - rdz = 1.0 / (zpm(k+1)-zpm(k)) -! dry -! bnv2 = grav * (rdz * ( tp(k+1)-tp(k)) +grcp) /tp(k) -! -! wet -! - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtk -! if (bnv2 < 0) print *, k, bnv2, ' bnv2 < 0 ', klow, ktop - bnv2 = max(bnv2, bnv2min ) - dzp = pint(k+1)-pint(k) - - dphm = dphm + dzp - uhm = uhm + up(k)*dzp - vhm = vhm + vp(k)*dzp - rhm = rhm + rhok*dzp - bn2hm = bn2hm + bnv2 * dzp - bn2(k) = bnv2 - enddo - - uhm = uhm/dphm - vhm = vhm/dphm - rhm = rhm/dphm - bn2hm = bn2hm/dphm - rhohm = rhm/dphm -! -! print *, ' MF-BV ', bn2hm, bn2(ktop), bn2(klow) -! - end subroutine um_flow -! -! - subroutine mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - - implicit none - - integer :: levs - real, dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(levs+1) :: pint, rho, zpi - real, dimension(levs) :: zdelpi, zdelpm - real :: zul, bvl - real, dimension(levs+1) :: ui, vi, bn2i, bvi, rhoi, ti, qi - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp - real :: vtji - integer :: k -! -! get interface values from surf to top -! - do k=2,levs - vi(k) = 0.5 *(vp(k-1) + vp(k)) - ui(k) = 0.5 *(up(k-1) + up(k)) - ti(k) = 0.5 *(tp(k-1) + tp(k)) - qi(k) = 0.5 *(qp(k-1) + qp(k)) - enddo - - k=1 - ti(k) = tp(k) - ui(k) = up(k) - vi(k) = vp(k) - qi(k) = qp(k) - k= levs - ti(k+1) = tp(k) - ui(k+1) = up(k) - vi(k+1) = vp(k) - qi(k+1)=qp(k) - - do k=1,levs-1 - vtj = tp(k) * (1.+fv*qp(k)) - vtji = ti(k) * (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj ! density kg/m**3 - rhoi(k) = rdi * pint(k) / vtji - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rdz = 1. / ( zpm(k+1)-zpm(k)) - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtji - bn2i(k) = max(bnv2, bnv2min ) - bvi(k) = sqrt( bn2i(k) ) - vtk = vtkp - enddo - k = levs - vtj = tp(k) ! * (1.+fv*qp(k)) - vtji = ti(k) !* (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj - rhoi(k) = rdi * pint(k) / vtji - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) - k = levs+1 - rhoi(k) = rdi * pint(k) / ti(k) - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) -! do k=1,levs -! write(6, 121) k, zpm(k)*1.e-3, zpi(k)*1.e-3, bvi(k), rho(k), rhoi(k) -! enddo - 121 format(i5, 2x, 3(2x, F10.3), 2(2x, E10.3)) - - end subroutine mflow_tauz - -! - subroutine get_unit_vector(u, v, u_n, v_n, mag) - implicit none - real, intent(in) :: u, v - real, intent(out) :: u_n, v_n, mag -! - - mag = sqrt(u*u + v*v) - - if (mag > 0.0) then - u_n = u/mag - v_n = v/mag - else - u_n = 0. - v_n = 0. - end if - - end subroutine get_unit_vector -! diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 index 3c42e573b..838ead1ee 100644 --- a/physics/cires_ugwpv1_triggers.F90 +++ b/physics/cires_ugwpv1_triggers.F90 @@ -11,42 +11,6 @@ module cires_ugwpv1_triggers !> @{ !! !! - subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) -!================= -! V0: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) - real(kind=kind_phys) :: 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_v0 -! - - -! subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) !================= ! V1: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* diff --git a/physics/cires_vert_lsatdis.F90 b/physics/cires_vert_lsatdis.F90 deleted file mode 100644 index 362bed8ef..000000000 --- a/physics/cires_vert_lsatdis.F90 +++ /dev/null @@ -1,524 +0,0 @@ - subroutine ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & -! fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1) - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs, nw, naz, ksrc - real :: kxw - real, dimension(nw) :: taub_spect, ch - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - - real, dimension(levs+1 ) :: uaz - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - real, dimension(levs+1 ) :: taux, tauy - real, dimension(levs ) :: dzirho , dzpi - real :: usrc -! - integer :: iaz, k -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - - do k=1,levs - dzpi(k) = -(pint(k+1)-pint(k))/rho(k)*rgrav - dzirho(k) = 1./rho(k)/dzpi(k) ! grav/abs(dp(k)) still hydrostatic "UGWP" - enddo - - LOOP_IAZ: do iaz =1, naz - usrc = ui(ksrc)*xaz(iaz) +vi(ksrc)*yaz(iaz) - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) -usrc - enddo -! -! if (nw .le. 4) call stochastic ..ugwp_lsatdis_az1 only 4-waves ch_ngw1, fuw_ngw1, eff_ngw1=1 -! -! multi-wave scheme -! - if (nw .gt. 4) then - call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & - fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - endif -! - ENDDO LOOP_IAZ ! Azimuth of GW propagation directions -! -! sum over azimuth and project aTau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum(kedd(k,:)) - enddo - - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) -! -! end solver: gw_azimuth_solver_LS81 -! sign Ax in rho*dU/dt = -d(rho*tau)/dz -! [(k) - (k+1)] - ax =0. ; ay = 0. - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - return - -! - print * - print *, ' Ax: ', maxval(Ax(ksrc:levs))*86400., minval(Ax(ksrc:levs))*86400. - print *, ' Ay: ', maxval(Ay(ksrc:levs))*86400., minval(Ay(ksrc:levs))*86400. - print *, 'Eps: ', maxval(Eps(ksrc:levs))*86400., minval(Eps(ksrc:levs))*86400. - print *, 'Ked: ', maxval(Ked(ksrc:levs))*1., minval(Ked(ksrc:levs))*1. -! print *, 'Atau ', maxval(atau(ksrc:levs, 1:Naz))*1.e3, minval(atau(ksrc:levs, 1:Naz))*1.e3 -! print *, 'taux_gw: ', maxval(taux( ksrc:levs))*1.e3, minval(taux( ksrc:levs))*1.e3 - print * -!----------------------------------------------------------------------- -! Here we can apply "ad-hoc" or/and "stability-based" limiters on -! (axy_gw, ked_gw and eps_gw) and check vert-inegrated conservation laws: -! energy and momentum and after that => final update gw-phys tendencies -!----------------------------------------------------------------------- - - end subroutine ugwp_lsatdis_naz -! - subroutine ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_sp, & - fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) - -! call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & -! fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & -! kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - use cires_ugwp_module, only : F_coriol, F_nonhyd, F_kds, linsat, linsat2 - use cires_ugwp_module, only : iPr_ktgw, iPr_spgw, iPr_turb, iPr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! - implicit NONE -! - integer, intent(in) :: nw ! number of GW modes in given direction - integer, intent(in) :: levs ! vertical layers - integer, intent(in) :: ksrc ! level of GW-launch layer - - real , intent(in) :: kxw ! horizontal wavelength - real , intent(in) :: ch(nw) ! horizontal phase velocities - real , intent(in) :: taub_sp(nw) ! spectral distribution of the mom-flux -! - real, intent(in) :: fcor, c2f2 ! Corilois factors - - real , intent(in) :: um(levs+1) - real , intent(in) :: tm(levs+1) -!in - real, intent(in), dimension(levs) :: rho, zm - real, intent(in), dimension(levs+1) :: rhoi, zi - real, intent(in), dimension(levs+1) :: bn2, bn - real, intent(in), dimension(levs) :: dzpi, dzirho - real, intent(in), dimension(levs+1) :: kvg, ktg, krad, kion, kmol -!======================================================================== -!out - real, dimension(levs+1) :: tau, ked - real, dimension(levs) :: eps - -!========================================================================= -!local - real :: Fd1, Fd2 - real, dimension(levs) :: a_mkz - real, dimension(levs+1,nw) :: sp_tau, sp_ked, sp_kth - real, dimension(levs,nw) :: sp_eps - - real, dimension(levs,nw) :: sp_mkz, sp_etot - real, dimension(levs,nw) :: sp_ek, sp_ep - - - real, dimension(levs) :: swg_ep, swg_ek, swg_et, swg_kz - - real, dimension(nw) :: rtaus ! spectral distribution at ksrc - real :: sum_rtaus ! total flux in iaz-azimuth - real :: Chnorm, Cx, Cs, Cxs, Cx2sat - real :: Fdis, Fdisat - real :: Cdf2, Cdf1 ! (Cd*cd-f*f) and sqrt -! -! two-level => upward integration for wave-filtering (dissip + breaking) -! - real :: taus, tauk, tau_lin - real :: etws, etwk, etw_lin - real :: epss, epsk - real :: kds, kdk - real :: kzw, kzw2, kzw3, kzi, kzs - real :: wfd, wfi ! -! -! for GW dissipation on the rotational sphere -! - real :: Betadis ! Ep/Ek ratio - real :: BetaM, BetaT ! 0.5 or 1./1+b and 1-1/(1+b) - real :: wfdM, wfdT, wfiM, wfiT, wdop2 - - real :: dzi, keff, keff_m, keff_t, keffs - - real :: sf2k2, cf2 - real :: Lzkm, Lzsat - - integer :: i, k, igw - integer :: ksat1, ksat2 - - real :: zsat1, zsat2 - real :: kx2_nh - - real :: rab1, rab2, rab3, rab4, cd_ulim2 - - integer :: Ind_out(nw, levs+1) - -! - logical, parameter :: dbg_print = .false. -! -!=================================================================== -! Nullify arrays -! tau, eps, ked -!==================================================================== - - tau = 0.0 - eps = 0.0 - ked = 0.0 - Ind_out(1:nw,:) = 0 -! -! GW-spectral arrays ..... sp_etot ....sp_tau -! - sp_tau = 0. - sp_eps = 0. - sp_ked = 0. - sp_mkz = -99. - sp_etot = 0. - sp_ek = 0. - sp_ep = 0. - sp_kth = 0. -! - swg_et = 0. - swg_ep = 0. - swg_ek = 0. - swg_kz = 0. - cd_ulim2 = cd_ulim*cd_ulim - cf2 = F_coriol*c2f2 - kx2_nh = F_nonhyd*kxw*kxw - - if (dbg_print) then - write(6,*) linsat , ' eff-linsat & kx ', kxw - write(6,*) maxval(ch), minval(ch), ' ch ' - write(6,*) - write(6,*) maxval(rhoi), minval(rhoi), 'rhoi ' - write(6,*) zi(ksrc) , ' zi(ksrc) ' - write(6,*) cd_ulim, ' crit-level cd_ulim ' - write(6,*) F_coriol, ' F_coriol' - write(6,*) F_nonhyd, ' F_nonhyd ' - write(6,*) maxval(Bn), minval(BN), ' BN-BV ' - write(6,*) Um(ksrc), ' Um-ksrc ', cd_ulim2 , 'cd_ulim2 ', c2f2, ' c2f2 ' - !pause - endif - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Loop_GW: over GW-spectra -! of individual non-interactive modes -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - Loop_GW: do i=1, nw -! - Kds = 0.0 -! -! src-level -! - Cx = ch(i) - Um(ksrc) - Cdf2 = Cx*Cx - cf2 - taus = taub_sp(i) ! momentum flux for i-mode w/o rhoi(ksrc) - kzw = Bn(ksrc) / Ch(i) ! ch(i) > 0. Cx(i) < 0. critica - etws = taus*kzw / kxw - rtaus(i) = taus*rhoi(ksrc) -! - IF( Cx <= cd_ulim .or. Cdf2 <= cd_ulim2) THEN - Ind_out(i, ksrc) =-1 ! -1 - diagnostic index for critical levels - cycle Loop_GW ! got to the next mode of GW-spectra - ELSE -! - kzw2 = Bn2(ksrc)/Cdf2 - rhp4 - kx2_nh -! - if (kzw2 <= 0.) then - Ind_out(i, ksrc) =-2 ! -2 - diagnostic index for reflected waves - cycle Loop_GW ! no wave reflection in GW-LSD scheme - endif - - kzw = sqrt(kzw2) - kzw3 = kzw2*kzw - etws = taus*kzw/kxw -! -! Here Linsat == Fr_critical -! - Cx2sat = Linsat2*Cdf2 - if (etws >= cx2sat) then - Kds = kxw*Cx*rhp2/kzw3 - etws = cx2sat - taus = etws*kxw/kzw - Ind_out(i, ksrc) =-3 ! -3 - dignostic index for saturated waves - endif -! - betadis = cdf2/(Cx*Cx+cf2) - betaM = 1.0 /(1.0+betadis) - betaT = 1.0 - BetaM -! - Cxs = Cx - kzs = kzw -! keffs = (kvg(ksrc)+kds)*iPr_turb*.5*khp -! sp_kth(ksrc, i) = rhoi(ksrc)*keffs*(Tm(ksrc)+Tm(ksrc-1)) - rtaus(i) = taus*rhoi(ksrc) - sp_tau(ksrc, i) = rtaus(i) - sp_etot(ksrc, i) = etws - sp_mkz(ksrc, i) = kzw - sp_ek(ksrc, i) = etws*betam - sp_ep(ksrc, i) = etws*betaT ! can be transferred to (T'**2) T-rms - -! - ENDIF ! vertical propagation of i-mode to the next upper layer = (ksrc+1) -! -! Loop_Zint .................................. VERTICAL "INTERFACE" LOOP from ksrc => ktop_GW -! - Loop_Zi: do k=ksrc+1, levs -! - Cx = ch(i)-Um(k) ! Um(k) is defined at the interface pressure levels - Cdf2 = Cx*Cx -cf2 - if( Cx <= cd_ulim .or. Cdf2 <= 0.) then - Ind_out(i, k) =-1 ! 1 - diagnostic index for critical levels - ! print*,'crit level C-U ',int(Cx),int(sqrt(cf2)),' Um ',Um(k) - cycle Loop_GW - endif - - cdf1 =sqrt(Cdf2) - wdop2 = (kxw*Cx)* (kxw*Cx) - kzw2 = (Bn2(k)-wdop2)/Cdf2 - rhp4 - kx2_nh ! full lin DS-NIGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) - - if (kzw2 < 0.) then - Ind_out(i, k) =-2 ! 2 - diagnostic index for reflected waves - cycle Loop_GW - endif - kzw = sqrt(kzw2) - kzw3 =kzw2*kzw -! - keff_m = kvg(k)*kzw2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*kzw2 + krad(k) -! -! - betadis = cdf2 / (Cx*Cx+cf2) - betaM = 1.0 / (1.0+betadis) - betaT = 1.0 - BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*kzw2*F_kds + keff_m - wfiT = kds*iPr_ktgw*F_kds * kzw2 + keff_t -! - wfdM = wfiM/(kxw*Cdf1)*BetaM - wfdT = wfiT/(kxw*Cx)*BetaT -! exp-l: "kzi*dz" - kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) ! 2-factor energy-momentum (U')^2 -!------------------------------------------------------- -! dissipative factor: Fdis -! we can replace WKB-solver by Numerical integration of -! tau_gw == etot_gw/kzw*kxw -! d(rho*tau_gw) = -kdis*rho*tau_gw -! |tau_gw| <= |tau_gwsat| -! linear limit for single mode -! generalization for the "broad" spectra -! or treating single mode breaking -! over finite "vertical"-depth with "efficiency" -! Now: time-step + hor-l scale -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Fdis = exp(-kzi) -! -! -! dissipative "wave rms" by WKB -! - etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*kzw/kzs -! - Cx2sat = Linsat2*Cdf2 -! -! Linear saturation -! - if (etwk.ge.cx2sat) then - - Ind_out(i, k) =-3 ! 3 - dignostic index for saturated waves -! ! saturate energy and "trigger" keddy - etw_lin = etwk - etwk = cx2sat - Kds = kxw*Cdf1*rhp2/kzw3 - tauk = etwk*kxw/kzw - -!=================================================================================== -! WAM/case with high Kds tau_lin = (etw_lin-etwk)*kxw/kzw !tau_loss by sat theory -! Lzsat = 6,28/kzw Zsat1 = Zi(k)-.5*Lzsat -! Zsat2 = Zi(k)+.5*Lzsat -! in WAM triggering from "kds = 0 m2/s" => "200 m2/s" for Lzw ~ 10 km -! -! call sat_domain(zi, Zsat1, Zsat2, pver, ksat1, ksat2) -! -! to avoid it do the new diss-n factor with eddy "kds" added to the -! background keff_m and keff_t -! -! can be taken out for the strato-mesosphere in GFS -! wfiM = kds*kzw2 + keff_m -! wfiT = kds*iPr_ktgw * kzw2 +keff_t -! wfdM = wfiM/(kxw*Cdf1)*BetaM -! wfdT = wfiT/(kxw*Cx)*BetaT -! kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) -! Fdisat = exp(-kzi) -! etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*(kzw/Kzs) -! updated breaking in the Lzsat-domain: zsat1 < zi < zsat2 -! ================================================================================= - else - kds = 0.0 - tauk = etwk*kxw/kzw ! = Ekin*kx/kz - ENDIF -!-------------------------------------- -! -! Fill in spectral arrays(levs, nw) -! -!-------------------------------------- - sp_ked(k,i) = kds ! defined at interfaces - sp_tau(k, i) = tauk*rhoi(k) ! defined at interfaces - -! keff = (kds + kvg(k))*iPr_turb*0.5*KHP -! sp_kth(k, i) = rhoi(k)*keff*(Tm(k)+Tm(k-1)) ! defined at mid-layers - - sp_etot(k, i) = etwk ! defined at interfaces - sp_mkz(k, i) = kzw ! defined at interfaces - sp_ek(k, i) = etwk*betam ! defined at interfaces - sp_ep(k, i) = etwk*betaT ! can be transferred to (T'**2) -! -! - if (sp_tau(k,i) > sp_tau(k-1,i)) then - sp_tau(k,i) = sp_tau(k-1,i) ! prevent "possible" numerical "noise" - endif -! -! updates for "eps and keff" from -! - rab1 =.5*(cx+cxs)*dzirho(k) -! heating -! due to wave dissipation -! - sp_eps(k,i) = rab1*(sp_tau(k-1,i)- sp_tau(k,i)) ! defined at mid-layers -! -! cooling term due to eddy heat conduction =0 if Keff_cond =>0, -! usually updated by 1D-heat implict tridiagonal solver -! explicit local solver ---->sp_kth(k,i) = Kt*(dT/dz+ R/Cp*T/Hp~>g/cp) -! -! sp_eps(k,i)=sp_eps(k,i)+dzirho(k)*(sp_kth(k,i)- sp_kth(k-1,i)) -! - kzs = kzw - cxs = cX - taus = tauk - etws = etwk -! keffs = keff - - enddo Loop_Zi ! ++++++++++++++ vertical layer -! -! ................................! stop ' in solver single-mode' -! - enddo Loop_GW ! i-mode of GW-spectra -! - sum_rtaus =sum(rtaus) ! total momentum flux at k=ksrc - -! print *, sum_rtaus, ' tau-src ', nint(zi(ksrc)*1.e-3) -! print *, maxval(ch), minval(ch), ' Ch ', ngwv, ' N-modes ' -! -!============================================================================== -! Perform spectral integartion (sum) & apply "efficiency/inremittency" factors -! -! eff_factor: ~ 1./[number of modes in 1-direction of model columns] -! -!============================================================================== - do k=ksrc, levs - - ked(k) =0. - Eps(k) = 0. - Tau(k) = 0. - swg_et(k) =0. - swg_ep(k) =0. - swg_ek(k) =0. - - do i=1,nw - Ked(k) = Ked(k)+sp_ked(k,i) - Eps(k) = Eps(k)+sp_eps(k,i) - Tau(k) = Tau(k)+sp_tau(k,i) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! GW-energy + GW-en flux ~ Cgz*E, diagnostics-only -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - swg_et(k) = swg_et(k)+sp_etot(k,i) !*eff_fact - swg_ep(k) = swg_ep(k)+sp_ep(k,i) !*eff_fact - swg_ek(k) = swg_ek(k)+sp_ek(k,i) !*eff_fact - enddo - - enddo -! fill in below the "source" level ..... [1:ksrc-1] -! - do k=1, ksrc-1 -! no loss of the total momentum flux - ked(k) =0. - eps(k) = 0. - tau(k) = tau(ksrc) -! lin-theory diagnostics-only - swg_et(k) =swg_et(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ep(k) =swg_ep(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ek(k) =swg_ek(ksrc)*rhoi(ksrc)/rhoi(k) - enddo -! - RETURN -! -! diagnostics below -! -345 FORMAT(2x, F8.2, 4(2x, F10.3), 2x, F8.2) - if (dbg_print) then - print * - print *, ' Zkm EK m2/s2 Ked m2/s Eps m2/s3 tau-Mpa ' - do k=ksrc, levs -! Fd1 = maxval(Fdis_modes(1:nw,k)) -! Fd2 = minval(Fdis_modes(1:nw,k)) - write(6, 345) Zi(k)*1.e-3, sqrt(swg_ek(k)), Ked(k), Eps(k), Tau(k)*1.e3, Um(k) !, Fd1, Fd2 - enddo - print * - write(6,*) nw , ' nwaves-linsat ' - write(6,*) maxval(sp_ked), minval(sp_ked), 'ked ' - write(6,*) maxval(sp_tau), minval(sp_tau), 'sp_tau ' - !pause - endif - -! - end subroutine ugwp_lsatdis_az1 -! - subroutine ugwp_limit_1d(ax, ay,eps, ked, levs) - use cires_ugwp_module, only : max_kdis, max_eps, max_axyz - implicit none - integer :: levs - real, dimension(levs) :: ax, ay,eps - real, dimension(levs+1) :: ked - real, parameter :: xtiny = 1.e-30 - where (abs(ax) > max_axyz ) ax = ax/abs(ax+xtiny)*max_axyz - where (abs(ay) > max_axyz ) ay = ay/abs(ay+xtiny)*max_axyz - where (abs(eps) > max_eps ) eps = eps/abs(eps+xtiny)*max_eps - where (ked > max_kdis ) ked = max_kdis - end subroutine ugwp_limit_1d diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 deleted file mode 100644 index 0d3cce194..000000000 --- a/physics/cires_vert_orodis.F90 +++ /dev/null @@ -1,1018 +0,0 @@ -! 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, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init,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 -!======================== - -! character(len=8) :: strver = 'vay_2018' -! 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, only : bnv2min, grav, pi, pi2, dw2min, velmin - use cires_ugwp_module, only : frcrit, ricrit, linsat - use ugwp_oro_init, only : hpmax, cleff, frmax - use ugwp_oro_init, only : nwdir, mdir, fdir - use ugwp_oro_init, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init, only : coro, nridge, odmin, odmax - use ugwp_oro_init, only : strver -! - use ugwp_oro_init, only : mkz2min, lzmax, 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, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav - use cires_ugwp_module, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module, only : kvg, ktg, krad, kion - use ugwp_oro_init, 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 , only : rcpd2 - use ugwp_oro_init, 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 , only : rcpd2 - use ugwp_oro_init, 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 diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 deleted file mode 100644 index 852c114b0..000000000 --- a/physics/cires_vert_orodis_v1.F90 +++ /dev/null @@ -1,1047 +0,0 @@ -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 - - ! character(len=*), intent(out) :: errmsg - ! integer, intent(out) :: errflg -! - 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 - - - ! Initialize CCPP error handling variables - ! errmsg = '' - ! errflg = 0 - -!================================================== -! -! 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 - ! write(errmsg,'(*(a))') cdmb, sigma, hamp, ' MTB == 0' - ! errflg = 1 - ! return - ! 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 - ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' - ! errflg = 1 - ! return ! unstable PBL - ! end if - - 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, & -! 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, & - pi, grav, kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, xn, yn, umag, drtau, kdis) - - 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 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - 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 - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: bnv2min, pi2, rgrav - 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 - - pi2 = 2.0*pi - bnv2min = (pi2/1800.)*(pi2/1800.) - rgrav = 1.0/grav - - 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, con_cp, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - 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 -! -! 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 - - 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, con_cp, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - 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 -! -! 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 - 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/cires_vert_wmsdis.F90 b/physics/cires_vert_wmsdis.F90 deleted file mode 100644 index 9e0bbf37c..000000000 --- a/physics/cires_vert_wmsdis.F90 +++ /dev/null @@ -1,425 +0,0 @@ - subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! -! use para_taub, only : tau_ex - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs - integer :: nw, naz ! # - waves for each azimuth (naz) - integer :: ksrc ! source level - real :: kxw ! horizontal wn - real :: taub_lat ! lat-dep tau_bulk N/m2 -! - real, dimension(nw) :: ch, dch, taub_spect - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - real, dimension(levs+1 ) :: uaz - - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - - real, dimension(levs+1 ) :: taux, tauy, bnrho - real, dimension(levs ) :: dzirho , dzpi - -! - integer :: iaz, k , inc - real, parameter :: gcstar=1.0 - integer , parameter :: nslope=1 - real :: spnorm ! source level normalization factor for the Broad Spectra - real :: bnrhos ! sum(taub_spect*dc) = spnorm taub_sect_norm = taub_spect/spnorm -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - bnrhos = bvi(ksrc)/rhoi(ksrc) - do k=1,levs - dzpi(k) = zint(k+1)-zint(k) - dzirho(k) = 1.0 / (rho(k)*dzpi(k)) ! grav/abs(dp(k)) still hydrostatic "ugwp" - bnrho(k) = (rhoi(k)/bvi(k)) !*bnrhos * gcstar ! gcstar=1.0 and bnrho(k=ksrc) =1. - enddo - k = levs+1 - bnrho(k) = (rhoi(k)/bvi(k))*bnrhos -! -! re-define ch, dch, taub_spect, this portion can be moved to "ugwp_init" -! -! -! - call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) - - -! print *, ' after FVS93_ugwp ', nw, maxval(ch), minval(ch) -! -! do normaalization for the spectral element of the saturated flux -! - bnrho = bnrho *spnorm - -! print * -! do inc=1, nw -! write(6,221) inc, ch(INC),taub_lat*taub_spect(inc), spnorm, dch(inc) -!221 FORMAT( i6, 2x, F8.2, 3(2x, E10.3)) -! enddo -! pause - - loop_iaz: do iaz =1, naz - - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) - enddo -! -! -! multi-wave broad spectrum of FVS-93 with ~scheme of WMS-IFS 2010 -! -! print *, ' iaz before ugwp_wmsdis_az1 ', iaz -! - - call ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_spect, taub_lat, & - spnorm, fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, bnrho, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - -! print *, ' iaz after ugwp_wmsdis_az1 ', iaz - -! - enddo loop_iaz ! azimuth of gw propagation directions -! -! sum over azimuth and project atau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum( kedd(k,:)) - enddo -! - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) - -! end solver: gw_azimuth_solver_ls81 -! sign ax in rho*du/dt = -d(rho*tau)/dz -! [(k) - (k+1)] -! du/dt = ax = -1/rho*d( tau) /dz -! - ax =0. ; ay = 0. - - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - - return - end subroutine ugwp_wmsdis_naz - - -! ======================================================================= - subroutine ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_sp, tau_bulk, & - spnorm, fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, bnrho, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) -! -! use para_taub, only : tau_ex, xlatdeg !for exchange src-tau -! - use cires_ugwp_module, only : f_coriol, f_nonhyd, f_kds, linsat - use cires_ugwp_module, only : ipr_ktgw, ipr_spgw, ipr_turb, ipr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! ======================================================================= - integer :: levs, ksrc, nw - real :: fcor, c2f2, kxw -! - real, dimension(nw) :: taub_sp, ch, dch - real :: tau_bulk, spnorm - real, dimension(levs) :: zm, rho, dzirho, dzpi - real, dimension(levs+1) :: zi, um, tm, bn2, bn, rhoi, bnrho - real, dimension(levs+1) :: kvg, ktg, krad, kion, kmol - real, dimension(levs+1) :: ked, tau - real, dimension(levs ) :: eps -! -!locals - integer :: k, inc - real, dimension(levs+1) :: umi - real :: zcin, zci_min, ztmp, zcinc - real :: zcimin=0.5 ! crit-level precision, 0.5 and start of Ch_MIN - real, parameter :: Keff = 0.2 - - real, dimension(nw) :: zflux ! - real, dimension(nw) :: wzact, zacc ! =1 ..crit level change it - - real, dimension(levs) :: zcrt ! - real, dimension(nw, levs) :: zflux_z, zact - - real :: zdelp, kxw2 - real :: vu_eff, vu_lin, v_kzw, v_cdp, v_wdp, v_kzi - real :: dfsat, fdis, fsat, fmode, expdis - real :: vc_zflx_mode, vm_zflx_mode - real :: tau_g5 -! ======================================================================= -!eps, ked, tau - - eps (:) =0; ked = 0.0 ; - kxw2 = kxw*kxw -! - zcrt(1:levs) = 0.0 - umi(1:levs+1) = um -! umi(1:levs+1) = um(1:levs+1) -um(ksrc) - - zci_min = zcimin - -! CALL slat_geos5(1, xlatdeg(1), tau_g5) -! tau_bulk = tau_g5 !tau_bulk*0.75 !3.75e-2 -! - zflux(:) = taub_sp(:)*tau_bulk ! includes tau_bulk(x,y) and spectral normalization - - zflux_z(1:nw,ksrc)=zflux(:) - - tau(1:levs+1) = tau_bulk ! constant flux for all layers k0.0 ) then -! ztmp = sum( ch(:)*zacc(:)*zflux(:)*dch(:) ) -! zcrt(k)=ztmp/tau(k) -! else -! zcrt( k )=zcrt(k-1) -! endif -! --------------------------------------------------------- -! do saturation (eq. (26) and (27) of scinocca 2003) -! + add molecular/eddy dissipation od gw-spectra vay-2015 -! for each mode & direction -! x by exp(-mi*zdelp) x introduce ....... mi(nw) -! -! mode-loop + add molecular/eddy dissipation od gw-spectra vay-2015 -! - do inc=1,nw - if (zact(inc,k) == 0.0) then - zflux(inc) = 0.0 - zflux_z(inc,k) = zflux(inc) - else - vu_eff = kvg(k) ! + ktg (k) !* ipr_ktgw - vu_lin = kion(k) ! + krad(k) !* ipr_ktgw - vu_eff = 2.e-5*exp(zi(k)/7000.)+.01 - zcin= ch(inc) - -!======================================================================= -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= - v_cdp = zcin-umi(k) - v_wdp = kxw*v_cdp - if (v_wdp.gt.0) then - v_kzw = bn(k)/v_cdp !can be non-hydrostatic - v_kzi = abs(( v_kzw*v_kzw*vu_eff + vu_lin) /v_wdp*v_kzw) - expdis = exp(-2.*v_kzi*dzpi(k) ) - else - v_kzi = 0. - expdis = 1.0 - endif - fmode = zflux(inc) - fdis = fmode*expdis ! only dissipation/crit_lev degrades it -!------------------------ -! includes rho/bn /(rhos/bns) *spnorm -!------------------------ - fsat = bnrho(k)* v_cdp*v_cdp /zcin ! expression for saturated flux - ! zfluxs=gcstar*zfct( k)*(zcin-zui( k ))**2/zcin -! flux_tot - sat.flux -! - dfsat= fdis-fsat - if( dfsat > 0.0 ) then -! put sat-n limit - zflux(inc) = fsat - else -! assign dis-ve flux - zflux(inc) =fdis - endif - zflux_z(inc,k)=zflux(inc) - - if (zflux_z(inc,k) > zflux_z(inc,k-1) ) zflux_z(inc,k) = zflux_z(inc,k-1) - - endif - - enddo -! -! integrate over spectral modes zpu(y, z, azimuth) zact( inc, )*zflux( inc, )*[d("zcinc")] -! - tau(k) = sum( zflux_z(:,k)*dch(:)) -!------------------------------------------------------------------------------ -! define expressions for eps-heat + Ked, needs more work for the broad spectra -! formulation especially for Ked -! after defining Ked .....GW-eddy cooling needs to be added -! for now "only" heating here -!============================================================================== - eps(k) =0. - do inc=1, nw - if (zact(inc,k) == 0.0) cycle ! dc-integration + dtau/dz - vc_zflx_mode = zflux(inc) - - zdelp= abs(ch(inc)-umi(k)) * dch(inc) /dzpi(k) - vm_zflx_mode=zflux_z(inc,k-1) - eps(k) =eps( k ) + (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - - - enddo !inc=1, nw - ked(k) = Keff*eps(k)/bn2(k) -! -! -------------- -! - enddo ! end k do-loop vertical loop do k=ksrc+1, levs - -!top lid - k =levs+1 - ked(k) = ked(k-1) -! eps(k) = eps(k-1) - tau(k) =tau(k-1)*0.933 - -! from surface to ksrc-1 -! tau(1:ksrc) = tau(ksrc) - ked(1:ksrc) = 0. - eps( 1:ksrc) = 0. - -! -! output: eps, ked, tau for given azimuth -! - end subroutine ugwp_wmsdis_az1 -! -! - subroutine FVS93_ugwps(nw, ch, dch, taub_sp, spnorm, nslope, bn2, bn, bnrhos) - implicit none - integer :: nw, nslope - real :: bn2, bn, bnrhos -!! real :: taub_lat ! bulk - lat-dep momentum flux - real, dimension (nw) :: ch, dch, taub_sp -! locals - integer :: i, inc - real, parameter :: zcimin = 0.5, zcimax = 95.0, zgam =1./4. - real, parameter :: zms = 6.28e-3/2. ! mstar Lz ~ 2km - real :: zxran, zxmax, zxmin, zx1, zx2, zdx, ztx, rch - real :: bn3, bn4, zcin, tn4, tn3, tn2, cstar - real :: spnorm ! needs to be passed for saturation flux norm-n - real :: tau_bulk -!-------------------------------------------------------------------- -! -! transforms ch -uniform => 1/ch and back to non-uniform ch, dch -! -!------------------------------------------------------------------- -! note that this is expresed in terms of the intrinsic ch or vertical wn=N/cd -! at launch cd=ch-um(ksrc), the transformation is identical for all -! levels, azimuths and horizontal pixels -! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform -! - zxmax=1.0 /zcimin - zxmin=1.0 /zcimax - zxran=zxmax-zxmin - zdx=zxran/float(nw-1) ! d_kz or d_mi -! -! - zx1=zxran/(exp(zxran/zgam)-1.0 ) !zgam =1./4. - zx2=zxmin-zx1 -! -! add idl computations for zci =1/zx -! x = 1/c stretching transform to look at final ch(i), dch(i) -! - - do i=1, nw - ztx=float(i-1)*zdx+zxmin - rch=zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 - ch(i)=1.0 /rch !eq. 28 of scinocca 2003 - dch(i)=ch(i)*ch(i)*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 - enddo -! -! nslope-dependent flux taub_spect(nw) momentum flux spectral density -! need to check math....expressions -! eq. (25) of scinocca 2003 with u-uo=0 it is identical to all azimuths -! -! - cstar=bn/zms - bn4=bn2*bn2 ! four times - bn3=bn2*bn - if(nslope==1) then -! s=1 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc) =bnrhos * zcin*bn4/(bn4+tn4) - enddo -! - elseif(nslope==2) then -! s=2 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc)= bnrhos*zcin*bn4/(bn4+tn4*zcin/cstar) - enddo -! - elseif(nslope==-1) then -! s=-1 case - do inc=1, nw - zcin=ch(inc) - tn2=(zms*zcin)**2 - taub_sp(inc)=bnrhos*zcin*bn2/(bn2+tn2) - enddo -! s=0 case - elseif(nslope==0) then - - do inc=1, nw - zcin=ch(inc) - tn3=(zms*zcin)**3 - taub_sp(inc)=bnrhos*zcin*bn3/(bn3+tn3) - enddo - endif ! for n-slopes -!============================================= -! normalize launch momentum flux -! ------------------------------------ -! (rho x f^h = rho_o x f_p^total) integrate (zflux x dx) - - tau_bulk= sum(taub_sp(:)*dch(:)) - spnorm= 1./tau_bulk - - do inc=1, nw - taub_sp(inc)=spnorm*taub_sp(inc) - enddo - - end subroutine FVS93_ugwps - diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index c47079992..abb78e7a6 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,266 +1,3 @@ -! - module sso_coorde -! -! specific to COORDE-2019 project OGW switches/sensitivity -! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) -! pgd4=4 (4 timse taub, control pgwd=1) -! - use machine, only: kind_phys - real(kind=kind_phys),parameter :: pgwd = 1.0_kind_phys - real(kind=kind_phys),parameter :: pgwd4 = 1.0_kind_phys - logical, parameter :: debugprint = .false. - end module sso_coorde -! -! -! Routine cires_ugwp_driver_v0 is replaced with cires_ugwp.F90/cires_ugwp_run in CCPP -#if 0 - subroutine cires_ugwp_driver_v0(me, master, - & im, levs, nmtvr, dtp, kdt, imx, do_ugwp, do_tofd, - & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, - & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, - & phii, phil, del, hprime, oc, oa4, clx, theta, - & gamm, sigma, elvmax, sgh30, kpbl, - & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, - & tau_tofd, tau_mtb, tau_ogw, tau_ngw, - & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, - & rain, ntke, tke, lprnt, ipr) -!----------------------------------------------------------- -! Part 1 "old-revised" gfs-gwdps_v0 or "old" gwdps (if do_ugwp=.false.) -! Part 2 non-stationary multi-wave GWs FV3GFS-v0 -! Part 3 Dissipative version of UGWP-tendency application -! (similar to WAM-2017) -!----------------------------------------------------------- - use machine, only : kind_phys - 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 - implicit none -!input - - integer, parameter :: kp = kind_phys - - integer, intent(in) :: me, master - integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr - - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) - logical :: do_ugwp, do_tofd, lprnt - integer, intent(in) :: kpbl(im) - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd - &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area - &, rain - - real(kind=kind_phys), intent(in), dimension(im,levs) :: - &, ugrs, vgrs, tgrs, qgrs, prsl, prslk, phil, del - real(kind=kind_phys), intent(in), dimension(im,levs+1) :: - & phii, prsi - -! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) - real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc - &, theta, gamm, sigma, elvmax - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4, clx - real(kind=kind_phys), intent(in) :: tke(im,levs) -!out - real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt - &, gw_dTdt, gw_kdis - -!-----locals + diagnostics output - - real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt - &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt - - real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg - - real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, - & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw, turb_fac - real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw - &, du3dt_tms - real(kind=kind_phys), dimension(im) :: tem - -! locals - real(kind=kind_phys) :: rfac, tx1 - integer :: i, j, k, ix -! -! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax -! -! real(kind=kind_phys), dimension(im) :: hprime, -! & oc, theta, sigma, gamm, elvmax -! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 -! -! switches that activate impact of OGWs and NGWs along with eddy diffusion -! - real(kind=kind_phys), parameter :: pogw=1.0_kp, pngw=1.0_kp - &, pked=1.0_kp, zero=0.0_kp - &, ompked=1.0_kp-pked -! -! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS execute ugwp_driver_v0 ' -! write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr - write(6,*) ' COORDE EXPER pogw = ' , pogw - write(6,*) ' COORDE EXPER pgwd = ' , pgwd - write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 - print * - endif - - do i=1,im - zlwb(i) = zero - enddo -! -! 1) ORO stationary GWs -! ------------------ - - if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag - CALL GWDPS_V0(IM, levs, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, - & ugrs , vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, - & prslk, phii, phil, DTP,KDT, - & sgh30, HPRIME, OC, OA4, CLX, THETA, - & 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) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' - print * - endif - else ! calling old GFS gravity wave drag as is - do k=1,levs - do i=1,im - pdvdt(i,k) = zero - pdudt(i,k) = zero - pdtdt(i,k) = zero - pkdis(i,k) = zero - enddo - enddo - if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero) then - call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & - &, ugrs, vgrs, tgrs, qgrs & - &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& - &, hprime, oc, oa4, clx, theta, sigma, gamm & - &, elvmax, dusfcg, dvsfcg & - &, con_g, con_cp, con_rd, con_rv, imx & - &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) - endif - - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - endif -! - if (cdmbgwd(3) > zero) then -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) - -! call slat_geos5(im, xlatd, tau_ngw) -! - if (abs(1.0_kp-cdmbgwd(3)) > 1.0e-6_kp) then - if (cdmbgwd(4) > zero) then - do i=1,im - turb_fac(i) = zero - tem(i) = zero - enddo - if (ntke > 0) then - 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 - 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_kp, min(5.0_kp, tx1)) - enddo - 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, qgrs, prsl, prsi, - & phil, xlatd, sinlat, coslat, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_v0 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) - 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 - else - 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 - - if (pogw == zero) then -! zmtb = 0.; zogw =0. - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - 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 -!------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = zero ; ed_dvdt(i,k) = zero ; ed_dtdt(i,k) = zero - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, 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)*ompked + ed_dtdt(i,k)*pked - gw_dvdt(i,k) = gw_dvdt(i,k)*ompked + ed_dvdt(i,k)*pked - gw_dudt(i,k) = gw_dudt(i,k)*ompked + ed_dudt(i,k)*pked - enddo - enddo - - end subroutine cires_ugwp_driver_v0 -#endif ! !===================================================================== ! @@ -301,12 +38,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, !---------------------------------------- USE MACHINE , ONLY : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + use ugwp_common_v0,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 ugwpv0_oro_init, only : rimin, ric, efmin, efmax &, hpmax, hpmin, sigfaci => sigfac &, dpmin, minwnd, hminmt, hncrit &, RLOLEV, GMAX, VELEPS, FACTOP @@ -315,11 +52,11 @@ SUBROUTINE GWDPS_V0(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 sso_coorde, only : pgwd, pgwd4, debugprint + use cires_ugwpv0_module, only : kxw, max_kdis, max_axyz + !---------------------------------------- implicit none - integer, parameter :: kp = kind_phys + integer, parameter :: kp = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -452,22 +189,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! 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 .and. debugprint) 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 + kxridge = float(IMX)/arad * cdmbgwd(2) do i=1,im idxzb(i) = 0 @@ -543,9 +267,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, endif enddo - IF (npt == 0 .and. debugprint) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin + IF (npt == 0) then RETURN ! No gwd/mb calculation done endif @@ -918,16 +640,16 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, 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 + & heff*heff if ( FR > fcrit_gfs ) then TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 ! nonlinear FLUX Tau0...XLINV(I) + & * ULOW(I) * GFOBNV * EFACT ! nonlinear FLUX Tau0...XLINV(I) ! else ! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 + & * ULOW(I) * GFOBNV * EFACT ! ! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs ! @@ -1083,9 +805,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! --------------------------- IF( do_tofd ) then axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0 .and. debugprint) then - print *, 'VAY do_tofd from surface to ', ztop_tofd - endif + + DO I = 1,npt J = ipt(i) zpbl =rgrav*phil( j, kpbl(j) ) @@ -1099,8 +820,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, vp1(k) = v1(j,k) enddo - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, - & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + call ugwpv0_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, + & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) do k=1,km axtms(j,k) = utofd1(k) @@ -1151,8 +872,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! 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 + DTAUX = TAUD(I,K) * XN(I) + DTAUY = TAUD(I,K) * YN(I) Pdvdt(j,k) = DTAUY +Pdvdt(j,k) Pdudt(j,k) = DTAUX +Pdudt(j,k) @@ -1185,97 +906,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, RETURN - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0 .and. debugprint) 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(phil)*rgrav,minval(phil)*rgrav, 'zmet' - print *, maxval(phii)*rgrav,minval(phii)*rgrav, '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), - & phil(j,1)/9.81, 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 - -! - RETURN -!--------------------------------------------------------------- -! review of OLD-GFS code 2017/18 most substantial changes -! a) kref > idxzb if idxzb > KPBL "OK" clipped-hill for OGW -! b) tofd -sgh30 "OK" -! -! c) FR < Frc linear theory for taub-specification -! -! d) solver of Palmer et al. (1987) => Linsat of McFarlane -! -!--------------------------------------------------------------- end subroutine gwdps_v0 !=============================================================================== -! use fv3gfs-v0 -! first beta version of ugwp for fv3gfs-128 -! cires/swpc - jan 2018 -! non-tested wam ugwp-solvers in fv3gfs: "lsatdis", "dspdis", "ado99dis" -! they reqiure extra-work to put them in with intializtion and namelists -! next will be lsatdis for both fv3wam & fv3gfs-128l implementations -! with (a) stochastic-deterministic propagation solvers for wave packets/spectra -! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) -! (c) guidance from high-res runs for GW sources and res-aware tune-ups -!23456 -! -! call gwdrag_wam(1, im, ix, km, ksrc, dtp, -! & xlat, gw_dudt, gw_dvdt, taux, tauy) -! call fv3_ugwp_wms17(kid1, im, ix, km, ksrc_ifs, dtp, -! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, -! & taux,tauy,grav, amol_i, me, lstep_first ) -! -! !23456============================================================================== !>\ingroup cires_ugwp_run @@ -1297,21 +932,19 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv + use ugwp_common_v0 , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv &, rad_to_deg, deg_to_rad &, rdi, gor, grcp, gocp &, bnv2min, dw2min, velmin, gr2 ! - use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec + use ugwpv0_wmsdis_init, only : hpscale, rhp2, bv2min, gssec &, v_kxw, v_kxw2, tamp_mpa, zfluxglob &, maxdudt, gw_eff, dked_min &, nslope, ilaunch, zmsi &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang - &, nwav, nazd, zcimin, zcimax - - use sso_coorde, only : debugprint + &, nwav, nazd, zcimin, zcimax ! implicit none !23456 @@ -1426,26 +1059,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, phil(j,k) = philg(j,k) * rgrav enddo enddo -!----------------------------------------------------------- -! also other options to alter tropical values -! tamp = 100.e-3*1.e3 = 100 mpa -! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 -!----------------------------------------------------------- -! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) - -! phil = philg*rgrav - -! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] -! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp - - if (kdt ==1 .and. mpi_id == master .and. debugprint) then - print *, maxval(tm1), minval(tm1), 'vgw: temp-res ' - print *, 'ugwp-v0: zcimin=' , zcimin - print *, 'ugwp-v0: zcimax=' , zcimax - print * - endif -! !================================================= do iazi=1, nazd do jk=1,klev @@ -1589,7 +1203,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo - endif ! for slopes + endif ! for slopes ! ! normalize momentum flux at the src-level ! ------------------------------ @@ -1866,257 +1480,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! !--------------------------------------------------------------------------- -! - if (kdt == 1 .and. mpi_id == master .and. debugprint) then - print *, 'vgw done ' -! - print *, maxval(pdudt)*86400, minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400, minval(pdvdt)*86400, 'vgw ay' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400, minval(pdtdt)*86400,'vgw eps' -! -! print *, ' ugwp -heating rates ' - endif - return end subroutine fv3_ugwp_solv2_v0 -!------------------------------------------------------------------------------- -! -! Part-3 of UGWP-V01 Dissipative (eddy) effects of UGWP it will be activated -! after tests of OGW (new revision) and NGW with MERRA-2 forcing. -! -!------------------------------------------------------------------------------- - subroutine edmix_ugwp_v0(im, levs, dtp, - & t1, u1, v1, q1, del, - & prsl, prsi, phil, prslk, - & pdudt, pdvdt, pdTdt, pkdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) -! - use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rdi, fv -! &, pi, rad_to_deg, deg_to_rad, pi2 - &, bnv2min, velmin, arad - - implicit none - - integer, intent(in) :: me, master, kdt - integer, intent(in) :: im, levs - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in), dimension(im,levs) :: - & u1, v1, t1, q1, del, prsl, prslk, phil -! - real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi - real(kind=kind_phys),dimension(im,levs) :: pdudt, pdvdt, pdTdt - real(kind=kind_phys),dimension(im,levs) :: pkdis -! -! out -! - real(kind=kind_phys),dimension(im,levs) :: ed_dudt, ed_dvdt - real(kind=kind_phys),dimension(im,levs) :: ed_dTdt -! -! locals -! - integer :: i, j, k -!------------------------------------------------------------------------ -! solving 1D-vertical eddy diffusion to "smooth" -! GW-related tendencies: du/dt, dv/dt, d(PT)/dt -! we need to use sum of molecular + eddy terms including turb-part -! of PBL extended to the model top, because "phys-tend" dx/dt -! should be smoothed as "entire" fields therefore one should -! first estimate and collect "effective" diffusion and applied -! it to each part of tendency or "sum of tendencies + Xdyn" -! this "diffusive-way" is tested with UGWP-tendencies -! forced by various wave sources. X' =dx/dt *dt -! d(X + X')/dt = K*diff(X + X') => -! -! wave1 dX'/dt = Kw * diff(X')... eddy part "Kwave" on wave-part -! turb2 dX/dt = Kturb * diff(X) ... resolved scale mixing "Kturb" like PBL -! we may assume "zero-GW"-tendency at the top lid and "zero" flux -! or "vertical gradient" near the surface -! -! 1-st trial w/o PBL interactions: add dU, dV dT tendencies -! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " -! ed_X = X_ed - X => final eddy tendencies -!--------------------------------------------------------------------------- -! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) -! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp -! - real(kind=kind_phys) :: Sw(levs), Sw1(levs), Fw(levs), Fw1(levs) - real(kind=kind_phys) :: Km(levs), Kpt(levs), Pt(levs), Ptmap(levs) - real(kind=kind_phys) :: rho(levs), rdp(levs), rdpm(levs-1) - real(kind=kind_phys),dimension(levs) :: ktur, vumol, up, vp, tp - real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum - real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis - real(kind=kind_phys) :: rdz , uz, vz, ptz -! ------------------------------------------------------------------------- -! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt -! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) -! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit -! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 -! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 -! - real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 - real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb - real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb - real(kind=kind_phys), parameter :: ric =0.25 - real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 - real(kind=kind_phys), parameter :: prmax = 4.0 - real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps - real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. - - - real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur - integer :: nstab - real(kind=kind_phys) :: w1, w2, w3 - rdtp = 1./dtp - nstab = 1 - stab_dt = 0.9999 - - do i =1, im - - rdp(1:levs) = grav/del(i, 1:levs) - - up(1:levs) = u1(i,1:levs) +pdudt(i,1:levs)*dtp - vp(1:levs) = v1(i,1:levs) +pdvdt(i,1:levs)*dtp - tp(1:levs) = t1(i,1:levs) +pdTdt(i,1:levs)*dtp - Ptmap(1:levs) = (1.+fv*q1(i,1:levs))/prslk(i,1:levs) - rho(1:levs) = rdi*prsl(i, 1:levs)/tp(1:levs) - Pt(1:levs) = tp(1:levs)*Ptmap(1:levs) - - do k=1, levs-1 - rdpm(k) = grav/(prsl(i,k)-prsl(i,k+1)) - rdz = .5*rdpm(k)*(rho(k)+rho(k+1)) - uz = up(k+1)-up(k) - vz = vp(k+1)-vp(k) - ptz =2.*(pt(k+1)-pt(k))/(pt(k+1)+pt(k)) - shr2(k) = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - bn2(k) = grav*rdz*ptz - zmet = phil(j,k)*rgrav - zgrow = exp(zmet*h4) - if ( bn2(k) < 0. ) then -! -! adjust PT-profile to bn2(k) = bnv2min -- neutral atmosphere -! adapt "pdtdt = (Ptadj-Ptdyn)/Ptmap" -! -! print *,' UGWP-V0 unstab PT(z) via gwdTdt ', bn2(k), k - - rineg = bn2(k)/shr2(k) - bn2(k) = max(bn2(k), bnv2min) - kamp = sqrt(shr2(k))*sc2u *zgrow - ktur(k) =kamp* (1+8.*(-rineg)/(1+1.746*sqrt(-rineg))) - endif - ritur = max(bn2(k)/shr2(k), rimin) - if (ritur > 0. ) then - kamp = sqrt(shr2(k))*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur(k)= kamp * w1 * w1 - endif - vumol(k) = 2.e-5 *exp(zmet/hps) - ksum(k) =ktur(k)+Pkdis(i,k)+vumol(k) - ksum(k) = max(ksum(k), kedmin) - ksum(k) = min(ksum(k), kedmax) - stab = 2.*ksum(k)*rdz*rdz*dtp - if ( stab >= 1.0 ) then - stab_dt = max(stab_dt, stab) - endif - enddo - nstab = max(1, nint(stab_dt)+1) - dtstab = dtp / float(nstab) - ksum(levs) = ksum(levs-1) - Fw(1:levs) = pdudt(i, 1:levs) - Fw1(1:levs) = pdvdt(i, 1:levs) - Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) - - do j=1, nstab - call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, - & rdp, rdpm, Sw, Sw1) - Fw = Sw - Fw1 = Sw1 - enddo - - ed_dudt(i,:) = Sw - ed_dvdt(i,:) = Sw1 - - Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) - Kpt = Km*iPr_pt - Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) - do j=1, nstab - call diff_1d_ptend(levs, dtstab, Fw, Kpt, rdp, rdpm, Sw) - Fw = Sw - enddo - ed_dtdt(i,1:levs) = Sw(1:levs)/Ptmap(1:levs) - - enddo - - end subroutine edmix_ugwp_v0 - subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! S(:) = 0.0 ; S1(:) = 0.0 -! -! explicit diffusion solver -! - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. - cd - ad -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - S1(K) = F1(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) - enddo - k = levs - S(k) = F(k) - S1(k) = F1(k) - end subroutine diff_1d_wtend - - subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! -! explicit "eddy" smoother for tendencies -! - - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. -(cd +ad) -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - enddo - k = levs - S(k) = F(k) - end subroutine diff_1d_ptend + diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 20ab38897..4439845ad 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -1,8 +1,9 @@ !> \file ugwpv1_gsldrag.F90 -!! This file combines three gravity wave drag schemes under one ("ugwpv1_gsldrag") 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 +!! This introduces two gravity wave drag schemes ugwpv1/CIRES and GSL/drag_suite.F90 under "ugwpv1_gsldrag" suite: +!! 1) The "V1 CIRES UGWP" scheme as tested in the FV3GFSv16-127L atmosphere model and workflow, which includes: +!! a) the orograhic gravity wave drag, flow blocking scheme and TOFD (Beljaars et al, 2004). +!! b) the v1 CIRE ugwp non-stationary GW scheme, new revision that generate realistic climate of FV3GFS-127L +!! in the strato-mesosphere in the multi-year simulations (Annual cycles, SAO and QBO in th tropical dynamics). !! 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) @@ -10,8 +11,7 @@ !! (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: +!! See Valery Yudin's presentation at 2020 UFS User's meeting (Jul 2020): !! 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. @@ -172,7 +172,7 @@ subroutine ugwpv1_gsldrag_init ( & print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & - support but has Logic error" + support with but has Logic error" errflg = 1 return endif @@ -341,9 +341,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Preference use (im,levs) rather than (:,:) to avoid memory-leaks ! that found in Nov-Dec 2020 ! order array-description control-logical -! other in-variables -! out-variables -! local-variables +! other in-variables +! out-variables +! local-variables ! ! unified GSL and CIRES diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 ! @@ -453,7 +453,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init ! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa ! -! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 +! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 !------------ ! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 @@ -532,8 +532,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! 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 & - .or. do_ugwp_v1_w_gsldrag) then + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd) then ! ! to do: the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : ! @@ -581,7 +580,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd else ! -! not gsldrag scheme for example "do_ugwp_v1_orog_only" +! not gsldrag oro-scheme for example "do_ugwp_v1_orog_only" ! if ( do_ugwp_v1_orog_only ) then @@ -634,9 +633,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - ENDIF ! + ENDIF ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Begin non-stationary GW schemes ! ugwp_v1 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 8f8538077..b6bd83d2c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -1,5 +1,5 @@ !> \file unified_ugwp.F90 -!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! This file combines three two orographic GW-schemes cires_ugwp.F90 and drag_suite.F90 under "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 @@ -10,8 +10,6 @@ !! (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 !! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. @@ -29,8 +27,6 @@ !! 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. !! @@ -38,22 +34,12 @@ 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 cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize 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 @@ -78,7 +64,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & do_ugwp_v0, do_ugwp_v0_orog_only, do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - do_ugwp_v1, do_ugwp_v1_orog_only, errmsg, errflg) + errmsg, errflg) !---- initialization of unified_ugwp implicit none @@ -101,8 +87,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent (in) :: fn_nml2 !character(len=*), parameter :: fn_nml='input.nml' @@ -122,29 +107,12 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & ! 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 + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl)) .or. & + (do_ugwp_v0_orog_only.and.do_gsl_drag_ls_bl) ) 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 - - ! Test to make sure that if ugwp_v0 non-stationary-only is selected that - ! ugwp_v1 is not also selected - if ( do_ugwp_v0_nst_only .and. (do_ugwp_v1.or.do_ugwp_v1_orog_only) ) then - - write(errmsg,'(*(a))') "Logic error: do_ugwp_v0_nst_only can only be & - &selected if both do_ugwp_v1 and do_ugwp_v1_orog_only are not & - &selected" + &do_gsl_drag_ls_bl can be chosen" errflg = 1 return @@ -157,7 +125,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) 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, & + call cires_ugwpv0_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 @@ -169,13 +137,6 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & end if - if ( do_ugwp_v1 ) then - 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. end subroutine unified_ugwp_init @@ -192,12 +153,11 @@ end subroutine unified_ugwp_init !! subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & - do_ugwp_v1,errmsg, errflg) + errmsg, errflg) implicit none ! - logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only, & - do_ugwp_v1 + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -207,9 +167,7 @@ subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & if (.not.is_initialized) return - if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwp_mod_finalize() - - if ( do_ugwp_v1 ) call cires_ugwp_finalize() + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -251,7 +209,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_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - do_ugwp_v1, do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + gwd_opt, errmsg, errflg) implicit none @@ -266,7 +224,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss logical, intent(in) :: flag_for_gwd_generic_tend - ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + + ! elvmax is intent(in) for CIRES UGWPv1, 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 @@ -324,8 +284,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -337,8 +296,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis 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. integer :: nmtvr_temp @@ -357,8 +314,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! 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 @@ -377,37 +332,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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) - - end if - - 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 = varss - 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, & - 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) - +! +! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls +! + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + end if if ( do_ugwp_v0.or.do_ugwp_v0_orog_only.or.do_ugwp_v0_nst_only ) then @@ -445,7 +375,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (errflg/=0) return endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + 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 @@ -477,7 +407,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -520,10 +450,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, 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) + gw_dtdt(i,k) = gw_dtdt(i,k)+ Pdtdt(i,k) + gw_dudt(i,k) = gw_dudt(i,k)+ Pdudt(i,k) + gw_dvdt(i,k) = gw_dvdt(i,k)+ Pdvdt(i,k) + gw_kdis(i,k) = gw_kdis(i,k)+ 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) @@ -543,13 +473,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index f60bdc038..181ffad92 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,13 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - 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 + + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + dependencies=drag_suite.F90 ######################################################################## [ccpp-arg-table] @@ -239,22 +236,6 @@ 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 @@ -293,14 +274,6 @@ 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 @@ -1341,22 +1314,6 @@ 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 [gwd_opt] standard_name = gwd_opt long_name = flag to choose gwd scheme From a0efcb4e6124c5a2525b7158a144e13b24aed1b3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 1 Feb 2021 11:31:43 -0700 Subject: [PATCH 08/16] Update GFS_debug.F90 with new variables --- physics/GFS_debug.F90 | 86 ++++++++++++++++++++++++++++++++-------- physics/unified_ugwp.F90 | 4 +- 2 files changed, 72 insertions(+), 18 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2db523355..19bb2903c 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -824,8 +824,12 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_h', Grid%jindx1_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_h', Grid%jindx2_h) endif - ! Model/Control - ! not yet + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j1tau ', Grid%ddy_j1tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j2tau ', Grid%ddy_j2tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_tau', Grid%jindx1_tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_tau', Grid%jindx2_tau ) + endif end if #ifdef OPENMP !$OMP BARRIER @@ -1229,21 +1233,71 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ngw ', Interstitial%dudt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ngw ', Interstitial%dvdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_ngw ', Interstitial%dtdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_ngw ', Interstitial%kdis_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ofd ', Interstitial%dvdt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zobl ', Interstitial%zobl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + end if ! CIRES UGWP v0 - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + end if !-- GSD drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index b6bd83d2c..0454ed376 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -334,7 +334,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, errmsg,errflg) ! ! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls -! +! tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. @@ -375,7 +375,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (errflg/=0) return endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + 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 From f4c0b0bad8607ff4d9d5106bcad46253caf5944b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 1 Feb 2021 11:32:15 -0700 Subject: [PATCH 09/16] Replace tabs with whitespaces in physics/cires_ugwpv1_solv2.F90, trim trailing whitespaces --- physics/cires_ugwpv1_solv2.F90 | 1138 ++++++++++++++++---------------- 1 file changed, 569 insertions(+), 569 deletions(-) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index 07330cf8b..f282635e6 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -5,7 +5,7 @@ module cires_ugwpv1_solv2 !--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! 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 @@ -14,7 +14,7 @@ module cires_ugwpv1_solv2 subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) + pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- ! nov 2015 alternative gw-solver for nggps-wam @@ -23,17 +23,17 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! source function and *F90 CIRES-style of the code ! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out ! -------------------------------------------------------------------------------- -! - use machine, only : kind_phys +! + use machine, only : kind_phys use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt - + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch - + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max - + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & omega2, rcpd, rcpd2, pi, pi2, fv, & rad_to_deg, deg_to_rad, & @@ -41,39 +41,39 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & 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, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & gw_eff, & nslope, ilaunch, zms, & zci, zdci, zci4, zci3, zci2, & zaz_fct, zcosang, zsinang, nwav, nazd, & zcimin, zcimax, rimin, sc2, sc2u, ric -! +! implicit none ! real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top - real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 integer, parameter :: ener_norm =0 - integer, parameter :: ener_lsat=0 - integer, parameter :: nstdif = 1 - integer, parameter :: wave_sponge = 1 - + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + integer, intent(in) :: levs ! vertical level integer, intent(in) :: im ! horiz tiles integer, intent(in) :: mpi_id, master, kdt - - real(kind=kind_phys) ,intent(in) :: dtp ! model time step - real(kind=kind_phys) ,intent(in) :: tau_ngw(im) - - real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity - real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure - real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees real(kind=kind_phys) ,intent(in) :: sinlat(im) real(kind=kind_phys) ,intent(in) :: coslat(im) @@ -84,70 +84,70 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion - real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height ! -! -! -! local =========================================================================================== - +! +! +! local =========================================================================================== + real(kind=kind_phys) :: tauabs(im,levs) ! - real(kind=kind_phys) :: wrms(im,levs) ! - real(kind=kind_phys) :: trms(im,levs) ! - + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) ! -! local =========================================================================================== +! local =========================================================================================== real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind - - real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent - real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) -! - real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency - real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency - real(kind=kind_phys) :: rhoint(levs+1) ! interface density + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind real(kind=kind_phys) :: vint(levs+1) ! meridional wind real(kind=kind_phys) :: tint(levs+1) ! temp-re - - real(kind=kind_phys) :: irhodz_mid(levs) - real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation - real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) real(kind=kind_phys) :: v_zmet(levs+1) - real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: vueff(levs+1) real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax - + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti - real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: wrk3 real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew - real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif real(kind=kind_phys), dimension(levs) :: Qmid, AKT - real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint - real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen - + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + integer, dimension(levs) :: Anstab - - real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) - real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) real(kind=kind_phys) :: rdci(nwav), rci(nwav) real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level ! ! scalars -! - real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real(kind=kind_phys) :: c2f2, cf1, wave_distot - +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + real(kind=kind_phys) :: flux_norm ! norm-factor real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff ! - real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 real(kind=kind_phys) :: ucrit_max @@ -155,318 +155,318 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 -! +! real(kind=kind_phys) :: zdelp, zdelm, taud_min real(kind=kind_phys) :: tvc, tvm, ptc, ptm - real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 real(kind=kind_phys) :: fmode, expdis, fdis real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit real(kind=kind_phys) :: v_wdi, v_wdpc - real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam - + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop + integer :: ksrc, km2, km1, kp1, ktop ! ! Kturb-part -! - real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur - +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + real(kind=kind_phys) :: kamp, zmetk, zgrow real(kind=kind_phys) :: stab, stab_dt, dtstab - real(kind=kind_phys) :: nslope3 -! - integer :: nstab, ist + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist real(kind=kind_phys) :: w1, w2, w3, dtdif - - real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp real(kind=kind_phys) :: rstar, rstar2 real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: taub_ch, sigu2_ch real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr - + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + !-------------------------------------------------------------------------- -! +! nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw ! -! test for input fields +! test for input fields ! 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 - +! 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 - + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + rci(:) = 1./zci(:) rdci(:) = 1./zdci(:) - + rdtp = 1./dtp - rdtp2 = 0.5*rdtp - + rdtp2 = 0.5*rdtp + ksrc= max(ilaunch, 3) - km2 = ksrc - 2 + km2 = ksrc - 2 km1 = ksrc - 1 kp1 = ksrc + 1 ktop= levs+1 - + suprf(ktop) = kion(levs) - + do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + 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 + DO j=1, im jl =j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max ! ! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) +! + aprsl(1:levs) = prsl(jl,1:levs) ! ! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" ! - do k=1, levs + do k=1, levs if (aprsl(k) .lt. psrc ) exit enddo - ilaunch = max(k-1, 3) + ilaunch = max(k-1, 3) ksrc= max(ilaunch, 3) - - zngw(j) = zmet(j, ksrc) - - km2 = ksrc - 2 + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 km1 = ksrc - 1 kp1 = ksrc + 1 -!=====ksrc +!=====ksrc - 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) - 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) + 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) + 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) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch + taub_src = taub_ch + - - sigu2 = taub_src/rho_src/v_kxw * zms - sig_u2az(1:nazd) = sigu2 + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 ! ! compute diffusion-based arrays km2:levs -! +! do jk = km2, levs dz_meti(jk) = azmeti(jk+1)-azmeti(jk) - dz_met(jk) = azmet(jk)-azmeti(jk-1) - enddo -! --------------------------------------------- + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- ! 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) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) ! zthm = 2.0/(tvc+tvm) - rhp_wam = zthm*gor -!interface + rhp_wam = zthm*gor +!interface uint(jk) = 0.5*(aum(jk-1)+aum(jk)) vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) + tint(jk) = 0.5*(tvc+tvm) rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters -! +! ! 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)) - - - 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 -! + bn(jk) = sqrt(bn2(jk)) + + + 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 +! ! ! 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 - + 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 + ritur = bn2(jk)/shr2 kamp = sqrt(shr2)*sc2 *zgrow w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp vueff(jk) = ktur + kvg(jk) - - akt(jk) = gipr/tvc + + akt(jk) = gipr/tvc enddo - if (idebug_gwrms == 1) then + 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) + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) enddo - endif + endif ! ! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! +! jk = levs - + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + tint(ktop) = atm(jk)*(1. +fv*aqm(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) -! -! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity -! + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo - - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi ! ! project winds at ksrc -! +! do iaz=1, nazd ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) enddo ! - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) - - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 - + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + do iaz=1, nazd zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) ui(iaz, jk) = zu !- ul(iaz)*0. enddo enddo - - rstar = 1./cstar(ksrc) - rstar2 = rstar*rstar -! ----------------------------------------- + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- ! set launch momentum flux spectral density -! ----------------------------------------- +! ----------------------------------------- fpu(1:nazd, km2:ktop) =0. - + do inc=1,nwav - + zcin = zci(inc)*rstar - -! + +! ! integrate (flux(cin) x dcin ) old tau-flux and normalization ! flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) -! +! ! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] -! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo - + enddo + enddo -! +! ! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo -! + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! do inc=1, nwav flux(inc,1) = flux_norm*flux(inc,1) - enddo - - + enddo + + if (ener_norm == 1) then - snorm_ener = 0. + snorm_ener = 0. do inc=1,nwav - zcin = zci(inc)*rstar - - ze2 = zcin /(1.+ zcin**nslope3) - - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin enddo - - ekin_norm = 1./snorm_ener - + + ekin_norm = 1./snorm_ener + ! taub_src = sigu2 * rho_src * [v_kxw / zms ] -! sigu2 = taub_src*zms/(rho_src/v_kxw) -! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - - ze1 = taub_src*zms/bvi * ekin_norm - taub_src = 0. - +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 do jk=ksrc, ktop fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat enddo - - endif + + endif ! - do iaz=1,nazd + do iaz=1,nazd fpu(iaz, ksrc) = taub_src fpu(iaz, km1) = taub_src enddo - + ! copy flux-1 into other azimuths ! -------------------------------- @@ -476,146 +476,146 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & flux(inc,iaz) = flux(inc,1) enddo enddo - + ! if (mpi_id == master .and. ener_norm == 1) then ! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * ! endif - 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 + 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 - + ! -------------------------------- - wave_act(:,:) = 1.0 + wave_act(:,:) = 1.0 ! vertical do-loop do jk=ksrc, levs - jkp = jk+1 + jkp = jk+1 ! azimuth do-loop - do iaz=1, nazd - - sig_u2az_m(iaz) = sig_u2az(iaz) - - umfp = ui(iaz, jkp) + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) umfm = ui(iaz, jk) umfc = .5*(umfm + umfp) ! wave-cin loop dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) =0.0 + sig_u2az(iaz) =0.0 ! -! wave_dis(iaz, :) = vueff(jk) +! wave_dis(iaz, :) = vueff(jk) do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) + flux_m(inc, iaz) = flux(inc, iaz) zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if(wave_act(inc,iaz) == 1.0) then + 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) -!======================================================================= - +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then ! ! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption ! - wave_act(inc,iaz) =0. + wave_act(inc,iaz) =0. akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - - else - + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + v_wdp = v_kxw*v_cdp wdop2 = v_wdp* v_wdp - -! + +! ! rotational cut-off -! +! kzw2 = (bn2(jkp)-wdop2)/Cdf2 ! -!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 -! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! 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) +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) ! Kds_sat = kxw*Cdf1*rhp2/kzw3 !krad, kvg, kion, ktg v_cdp = sqrt( cdf2 ) v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due 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 + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due 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) - - flux_2_sig = v_kzw/v_kxw/rhoint(jkp) - w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) 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. - w1 =0. + fmode = 0. + w1 =0. endif ! expdis =1.0 - + fdis = fmode*expdis*wave_act(inc,iaz) !============================================================================== ! ! Saturated Fluxes and Energy: Spectral and Dicrete Modes -! +! ! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin ! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) ! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 ! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] ! ! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) ! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! +! ! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! +! ! ! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) ! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 @@ -623,402 +623,402 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] -! +! ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc -! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - - if (ener_norm == 1) then - -! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) - -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) -! - endif +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif !---------------------------------------------------------------------------- -! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw ! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat ! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat !---------------------------------------------------------------------------- zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa if(zdep > 0.0 ) then ! subs on sat-limit - ze1 = flux(inc,iaz) + ze1 = flux(inc,iaz) flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer else ! assign dis-ve flux flux(inc,iaz) = fdis endif - - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif ! ! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" ! if ( azmeti(jkp) .ge. zsp_gw) then - mi_sponge = .5/dz_meti(jk) - ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] - v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - 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) - exp_sponge = exp(-ze1) -! + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + 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) + exp_sponge = exp(-ze1) +! ! additional sponge -! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then endif ! only for waves w/o CL-absorption wave_act=1 ! ! sum for given (jk, iaz) all active "wave" contributions -! - if (wave_act(inc,iaz) == 1) then - - zcinc =zdci(inc) +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) vc_zflx_mode = flux(inc,iaz) vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz - + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! (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)*cdf1 *zcinc + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff - -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp ! cool = -Kt*N2/R -! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] -! +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) -! - enddo ! wave-inc-loop - + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + ze1 =fpu(iaz, jk) if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 ! ! compute wind and temp-re rms ! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + 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 + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif ! -------------- enddo ! end Azimuth do-loop - -! -! eddy wave dissipation to limit GW-rms -! - tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) - ze1=max(dked_min, tx1) - ze2=min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) -! + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/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 -! we allow non-zero momentum fluxes and thermal effects -! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = 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 + 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) + 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) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) - enddo + dked(jl,jk) = dked(jl,jk) + dfdz_heat(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) + 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 + + 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) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) enddo - enddo - endif + enddo + endif ! do jk=ksrc+1,levs jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp + 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 + 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 -! +! !maxdtdt= dked_max * bnfix2 -! +! pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - - dked(jl,jk) = dked(jl,jk)/bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif enddo -!---------------------------------------------------------------------------------- +!---------------------------------------------------------------------------------- ! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur ! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt ! can check "stability" in the column and "add" ktur-estimation ! to suppress instability as needed so dked = dked_gw + ktur_ric -!---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) ! - do ist= 1, nstdif + do ist= 1, nstdif do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) enddo dktur(ksrc:levs-1) = adif(ksrc:levs-1) enddo dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) dktur(levs+1) = dktur(levs) - + do jk=ksrc,levs - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo - + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + ! ! Thermal budget qmid = qheat + qcool -! - do jk=ksrc+1,levs +! + do jk=ksrc+1,levs ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) - enddo + dked(jl, jk) = dktur(jk) + enddo ! ! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" ! from the surface/launch-gw to the "top" -! +! ! ! update by source function X(t+dt) = X(t) + dtp * dXdt -! - uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp - vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp - told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp ! ! diagnose turb-profile using "stability-check" relying on the free-atm diffusion ! sc2 = 30m x 30m -! - dktur(km2:levs) = dked_min - - do jk=km1,levs - uz = uold(jk) - uold(jk-1) +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1./ze1 - + ze1 = dz_met(jk) + zdelm = 1./ze1 + tvc = told(jk) * (1. +fv*aqm(jk)) tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1./(1. + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) ! ! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const -! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur= min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur ! ! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur - - enddo - +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + ! ! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability -! - if (knob_ugwp_dokdis == 2) then - +! + if (knob_ugwp_dokdis == 2) then + do jk=km1,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - - kvint(ktop) = kvint(levs) - - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. - do jk=km1,levs-1 - - dzmetp = 1./dz_met(jk+1) - dzmetf = 1./(dz_meti(jk)*rhomid(jk)) - - - ktur = kvint(jk) *rhoint(jk) * dzmetf - kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk)+cdif(jk) - ACdif(jk) = ApC - - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - -! if (nstab .ge. 3) print *, 'nstab ', nstab -! + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! ! k instead Jk -! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif - - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo - - uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du - vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif - told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif ! ! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs ! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) enddo ! ! compute "smoothed" tendencies by molecular + GW-eddy diffusions -! - do k=ksrc,levs-1 -! +! + do k=ksrc,levs-1 +! ! final updates of tendencies and diffusion -! - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) - - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) - endif + endif if (abs(ze2) >= maxdudt ) then ze2 = sign(maxdudt, ze2) endif - - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) vz = vold(k+1) - vold(k-1) - ze2 = 1./(dz_met(k+1)+dz_met(k) ) - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity - - enddo - - - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + enddo ! J-loop -! - RETURN - -!================================= diag print after "return" ====================== +! + RETURN + +!================================= diag print after "return" ====================== if (kdt ==1 .and. mpi_id == master) then -! +! print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) ! print *, 'ugwpv1: 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 ! @@ -1029,8 +1029,8 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! ! print *, ' ugwp -heating rates ' endif -!================================= - return +!================================= + return end subroutine cires_ugwpv1_ngw_solv2 From 28a7793c5408bf2a8797f5809f2d34606207d035 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 3 Feb 2021 08:51:39 -0700 Subject: [PATCH 10/16] Fix uninitialized variables in physics/cires_ugwpv1_solv2.F90 --- physics/cires_ugwpv1_solv2.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index f282635e6..ee8f7bc83 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -840,7 +840,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) dktur(levs+1) = dktur(levs) - do jk=ksrc,levs + do jk=ksrc,levs+1 ze1 = .5*( dktur(jk) +dktur(jk-1) ) kvint(jk) = ze1 ktint(jk) = ze1*iPr_ktgw @@ -909,14 +909,14 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! if (knob_ugwp_dokdis == 2) then - do jk=km1,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) - kvint(ktop) = kvint(levs) - dzmetm = 1./dz_met(km1) Adif(km1:levs) = 0. Cdif(km1:levs) = 0. From 7d45f106c3caf2898d8f37cd462aabe95dbf435b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 9 Feb 2021 14:09:42 -0700 Subject: [PATCH 11/16] Update and cleanup of UGWPv0, UGWpv1 and drag suite standard names --- physics/GFS_debug.F90 | 38 +++++++---- physics/GFS_phys_time_vary.fv3.meta | 60 ++++++++--------- physics/cires_ugwp.meta | 12 ++-- physics/cires_ugwp_post.meta | 10 +-- physics/drag_suite.meta | 54 ++++++++-------- physics/ugwpv1_gsldrag.F90 | 8 +-- physics/ugwpv1_gsldrag.meta | 93 ++++++++++++--------------- physics/ugwpv1_gsldrag_post.meta | 18 +++--- physics/unified_ugwp.F90 | 20 +++--- physics/unified_ugwp.meta | 99 +++++++++++++---------------- physics/unified_ugwp_post.meta | 10 +-- 11 files changed, 208 insertions(+), 214 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 19bb2903c..8f072cae6 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1262,31 +1262,24 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zobl ', Interstitial%zobl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if ! CIRES UGWP v0 if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) @@ -1299,12 +1292,31 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if !-- GSD drag suite - if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then + if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & + Model%gwd_opt==2 .or. Model%gwd_opt==22) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ocss ', Interstitial%ocss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if + if (Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) + end if ! GFDL and Thompson MP if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index e20920686..887037924 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -316,7 +316,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -324,39 +324,39 @@ intent = in optional = F [jindx1_tau] - standard_name = index_interp_weight1_taungw - long_name = index1 for weight1 for tau NGWs + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = inout - optional = F + optional = F [jindx2_tau] - standard_name = index_interp_weight2_taungw - long_name = index2 for weight2 for tau NGWs + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = inout - optional = F + optional = F [ddy_j1tau] - standard_name = interp_weight1_taungw - long_name = interpolation weight1 for tau NGWs + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real - intent = inout + intent = inout kind = kind_phys - optional = F + optional = F [ddy_j2tau] - standard_name = interp_weight2_taungw - long_name = interpolation weight2 for tau NGWs + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real intent = inout kind = kind_phys - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -492,7 +492,7 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer intent = in @@ -1378,7 +1378,7 @@ intent = inout optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -1386,33 +1386,33 @@ intent = in optional = F [jindx1_tau] - standard_name = index_interp_weight1_taungw - long_name = index1 for weight1 for tau NGWs + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = in - optional = F + optional = F [jindx2_tau] - standard_name = index_interp_weight2_taungw - long_name = index2 for weight2 for tau NGWs + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = in - optional = F + optional = F [ddy_j1tau] - standard_name = interp_weight1_taungw - long_name = interpolation weight1 for tau NGWs + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real - intent = in + intent = in kind = kind_phys - optional = F + optional = F [ddy_j2tau] - standard_name = interp_weight2_taungw - long_name = interpolation weight2 for tau NGWs + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real @@ -1420,14 +1420,14 @@ kind = kind_phys optional = F [tau_amf] - standard_name = ngw_abs_momentum_flux + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag long_name = ngw_absolute_momentum_flux units = various dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index 887280612..e2afbf70f 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -565,7 +565,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -574,7 +574,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -583,7 +583,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -592,7 +592,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -673,7 +673,7 @@ intent = out optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -682,7 +682,7 @@ intent = out optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 80b8ce1ca..c8618e1c8 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index fa5b317fc..3035a2c95 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -274,7 +274,7 @@ intent = inout optional = F [dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -283,7 +283,7 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -292,7 +292,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -301,7 +301,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -310,7 +310,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -319,7 +319,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -328,7 +328,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -337,7 +337,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -364,72 +364,72 @@ intent = out optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -592,7 +592,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -600,7 +600,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -608,7 +608,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 4439845ad..28a4110fc 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -312,7 +312,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & rain, br1, hpbl, kpbl, slmsk, & ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, del, tau_amf, & - dudt_ogw, dvdt_ogw, dtdt_sso, du_ogwcol, dv_ogwcol, & + dudt_ogw, dvdt_ogw, du_ogwcol, dv_ogwcol, & dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & dudt_oss, dvdt_oss, du_osscol, dv_osscol, & dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & @@ -408,7 +408,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_osscol, dv_osscol, du_ofdcol, dv_ofdcol ! -! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) +! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) ! du_ngwcol, dv_ngwcol real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg @@ -419,9 +419,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_sso, dtdt_ngw, dtdt_gw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw ! diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 1cfec2104..2eac9a321 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -207,7 +207,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -215,7 +215,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -223,7 +223,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -231,7 +231,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -239,7 +239,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -247,7 +247,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -255,7 +255,7 @@ intent = in optional = F [do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only + standard_name = flag_for_ugwp_version_1_orographic_gwd long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -263,7 +263,7 @@ intent = in optional = F [do_ugwp_v1_w_gsldrag] - standard_name = do_ugwp_v1_w_gsldrag + standard_name = flag_for_ugwp_version_1_nonorographic_gwd long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL units = flag dimensions = () @@ -413,7 +413,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -421,7 +421,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -429,7 +429,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -437,7 +437,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -445,7 +445,7 @@ intent = in optional = F [do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only + standard_name = flag_for_ugwp_version_1_orographic_gwd long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -453,7 +453,7 @@ intent = in optional = F [do_ugwp_v1_w_gsldrag] - standard_name = do_ugwp_v1_w_gsldrag + standard_name = flag_for_ugwp_version_1_nonorographic_gwd long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL units = flag dimensions = () @@ -806,7 +806,7 @@ intent = in optional = F [tau_amf] - standard_name = ngw_abs_momentum_flux + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag long_name = ngw_absolute_momentum_flux units = various dimensions = (horizontal_loop_extent) @@ -815,7 +815,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -824,7 +824,7 @@ intent = out optional = F [dvdt_ogw] - standard_name = y_momentum_tendency_from_meso_scale_ogw + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -832,17 +832,8 @@ kind = kind_phys intent = out optional = F -[dtdt_sso] - standard_name = tendency_of_air_temperature_due_to_sso - long_name = air temperature tendency due to subgrid-scale orography - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [du_ogwcol] - standard_name = integrated_x_momentum_flux_from_meso_scale_ogw + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from meso scale ogw units = Pa dimensions = (horizontal_loop_extent) @@ -851,7 +842,7 @@ intent = out optional = F [dv_ogwcol] - standard_name = integrated_y_momentum_flux_from_meso_scale_ogw + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from meso scale ogw units = Pa dimensions = (horizontal_loop_extent) @@ -860,7 +851,7 @@ intent = out optional = F [dudt_obl] - standard_name = x_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -869,7 +860,7 @@ intent = out optional = F [dvdt_obl] - standard_name = y_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -878,7 +869,7 @@ intent = out optional = F [du_oblcol] - standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -887,7 +878,7 @@ intent = out optional = F [dv_oblcol] - standard_name = integrated_y_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -896,7 +887,7 @@ intent = out optional = F [dudt_oss] - standard_name = x_momentum_tendency_from_small_scale_gwd_vy + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -905,7 +896,7 @@ intent = out optional = F [dvdt_oss] - standard_name = y_momentum_tendency_from_small_scale_gwd_vy + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -914,7 +905,7 @@ intent = out optional = F [du_osscol] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd units = Pa dimensions = (horizontal_loop_extent) @@ -923,7 +914,7 @@ intent = out optional = F [dv_osscol] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd units = Pa dimensions = (horizontal_loop_extent) @@ -932,7 +923,7 @@ intent = out optional = F [dudt_ofd] - standard_name = x_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -941,7 +932,7 @@ intent = out optional = F [dvdt_ofd] - standard_name = y_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -950,7 +941,7 @@ intent = out optional = F [du_ofdcol] - standard_name = integrated_x_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -959,7 +950,7 @@ intent = out optional = F [dv_ofdcol] - standard_name = integrated_y_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -968,7 +959,7 @@ intent = out optional = F [dudt_ngw] - standard_name = tendency_of_x_wind_due_to_ngw + standard_name = tendency_of_x_wind_due_to_nonorographic_gravity_wave_drag long_name = zonal wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -977,7 +968,7 @@ intent = out optional = F [dvdt_ngw] - standard_name = tendency_of_y_wind_due_to_ngw + standard_name = tendency_of_y_wind_due_to_nonorographic_gravity_wave_drag long_name = meridional wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -986,7 +977,7 @@ intent = out optional = F [dtdt_ngw] - standard_name = tendency_of_air_temperature_due_to_ngw + standard_name = tendency_of_air_temperature_due_to_nonorographic_gravity_wave_drag long_name = air temperature tendency due to non-stationary GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -995,7 +986,7 @@ intent = out optional = F [kdis_ngw] - standard_name = eddy_mixing_due_to_ngw + standard_name = atmosphere_momentum_diffusivity_due_to_nonorographic_gravity_wave_drag long_name = eddy mixing due to non-stationary GWs units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1004,7 +995,7 @@ intent = out optional = F [dudt_gw] - standard_name = tendency_of_x_wind_due_to_allgw + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1013,7 +1004,7 @@ intent = out optional = F [dvdt_gw] - standard_name = tendency_of_y_wind_due_to_allgw + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1022,7 +1013,7 @@ intent = out optional = F [dtdt_gw] - standard_name = tendency_of_air_temperature_due_to_allgw + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to all GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1031,7 +1022,7 @@ intent = out optional = F [kdis_gw] - standard_name = eddy_mixing_due_to_allgw + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to all GWs units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1058,7 +1049,7 @@ intent = out optional = F [tau_oss] - standard_name = instantaneous_momentum_flux_due_to_sso + standard_name = momentum_flux_due_to_subgrid_scale_orographic_gravity_wave_drag long_name = momentum flux or stress due to SSO including OBL-OSS-OFD units = Pa dimensions = (horizontal_loop_extent) @@ -1085,7 +1076,7 @@ intent = out optional = F [zobl] - standard_name = height_of_mountain_blocking_v1 + standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag_v1 units = m dimensions = (horizontal_loop_extent) @@ -1094,7 +1085,7 @@ intent = out optional = F [zngw] - standard_name = height_of_launch_level_of_nonsta_gravity_wave + standard_name = height_of_launch_level_of_nonorographic_gravity_waves long_name = height of launch level of non-stationary GWs units = m dimensions = (horizontal_loop_extent) diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta index 9ed76d6e8..45fa4ea99 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/ugwpv1_gsldrag_post.meta @@ -46,7 +46,7 @@ intent = in optional = F [dudt_gw] - standard_name = tendency_of_x_wind_due_to_allgw + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -55,7 +55,7 @@ intent = in optional = F [dvdt_gw] - standard_name = tendency_of_y_wind_due_to_allgw + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -64,7 +64,7 @@ intent = in optional = F [dtdt_gw] - standard_name = tendency_of_air_temperature_due_to_allgw + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to all GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -73,7 +73,7 @@ intent = in optional = F [du_oblcol] - standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -82,7 +82,7 @@ intent = in optional = F [du_ofdcol] - standard_name = integrated_x_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -109,7 +109,7 @@ intent = in optional = F [zobl] - standard_name = height_of_mountain_blocking_v1 + standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag_v1 units = m dimensions = (horizontal_loop_extent) @@ -135,7 +135,7 @@ intent = in optional = F [dudt_obl] - standard_name = x_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -144,7 +144,7 @@ intent = in optional = F [dudt_ofd] - standard_name = x_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -153,7 +153,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 0454ed376..7fdc43b2b 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -185,7 +185,7 @@ end subroutine unified_ugwp_finalize !>@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). +!! 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 backgroufnd 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. !! @@ -203,7 +203,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, 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_mtb, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & 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, & @@ -244,7 +244,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & 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(:,:) @@ -253,11 +252,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & 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 + 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(:,:) :: dudt_mtb, dudt_tms + real(kind=kind_phys), intent(out), dimension(:,:) :: dtaux2d_ls, dtauy2d_ls ! These arrays are only allocated if ldiag=.true. real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw @@ -333,10 +333,10 @@ 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) ! -! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls +! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls ! tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. - dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + dudt_mtb = 0. ; dudt_tms = 0. end if diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 181ffad92..edb8521e0 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -189,7 +189,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -197,7 +197,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -205,7 +205,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -213,7 +213,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -221,7 +221,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -229,7 +229,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -259,7 +259,7 @@ name = unified_ugwp_finalize type = scheme [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -267,7 +267,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -512,80 +512,80 @@ intent = in optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) 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 + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -593,8 +593,8 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd - long_name = y momentum tendency from large scale gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in y wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -602,7 +602,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -611,7 +611,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -620,7 +620,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -629,7 +629,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -638,7 +638,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -647,7 +647,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -877,7 +877,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -886,7 +886,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -895,7 +895,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -904,7 +904,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -984,17 +984,8 @@ 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_loop_extent,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 + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1267,7 +1258,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -1275,7 +1266,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -1283,7 +1274,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -1291,7 +1282,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -1299,7 +1290,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -1307,7 +1298,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index 85a6bff8e..0e30d4489 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) From e354d11f5ff991c60ddadcef5df94e65c2f5c08f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 10 Feb 2021 16:14:02 -0700 Subject: [PATCH 12/16] Update physics/GFS_debug.F90 with additional UGWP changes --- physics/GFS_debug.F90 | 106 ++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 70 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 8f072cae6..cbc65fa79 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -675,6 +675,28 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if + ! UGWP - incomplete list + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%%dudt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%%dvdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%%dtdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%%kdis_gw) + if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_obl ', Diag%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_oss ', Diag%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_oss ', Diag%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ofd ', Diag%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ofd ', Diag%dvdt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ogwcol ', Diag%du_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ogwcol ', Diag%dv_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_oblcol ', Diag%du_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_oblcol ', Diag%dv_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_osscol ', Diag%du_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_osscol ', Diag%dv_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) + end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsi' , Statein%prsi) @@ -1233,63 +1255,25 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) + ! UGWP + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) + ! UGWP v1 if (Model%do_ugwp_v1) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ngw ', Interstitial%dudt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ngw ', Interstitial%dvdt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_ngw ', Interstitial%dtdt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_ngw ', Interstitial%kdis_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ofd ', Interstitial%dvdt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) - end if - ! CIRES UGWP v0 - if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if !-- GSD drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & @@ -1299,24 +1283,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if - if (Model%gwd_opt==33 .or. Model%gwd_opt==22) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - end if ! GFDL and Thompson MP if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) From 828759a2333074787b0d65f2eef93915a2b086f2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 11 Feb 2021 15:14:57 -0700 Subject: [PATCH 13/16] Update physics/GFS_debug.F90, and fix formatting in physics/ugwpv1_gsldrag.F90 --- physics/GFS_debug.F90 | 10 +- physics/ugwpv1_gsldrag.F90 | 382 ++++++++++++++++++------------------- 2 files changed, 197 insertions(+), 195 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index cbc65fa79..5ecc9d8a3 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -676,10 +676,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if ! UGWP - incomplete list - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%%dudt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%%dvdt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%%dtdt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%%kdis_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%dudt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%dvdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%dtdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%kdis_gw) if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) @@ -696,6 +696,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_osscol ', Diag%dv_osscol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) + else + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw) end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 28a4110fc..24ab2b2d1 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -37,12 +37,12 @@ module ugwpv1_gsldrag use machine, only: kind_phys - + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 - use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp - use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa - use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 - use cires_ugwpv1_oro, only: orogw_v1 + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 use drag_suite, only: drag_suite_run @@ -69,13 +69,13 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & - con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & 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, do_ugwp_v1_w_gsldrag, errmsg, errflg) - + use ugwp_common - + !---- initialization of unified_ugwp implicit none @@ -92,9 +92,9 @@ subroutine ugwpv1_gsldrag_init ( & real(kind=kind_phys), intent (in) :: dtp real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth - real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt 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, & @@ -115,20 +115,20 @@ subroutine ugwpv1_gsldrag_init ( & errmsg = '' errflg = 0 !============================================================================ -! +! ! gwd_opt => "1 and 2, 3, 22, 33' see previous GSL-commits -! related to GSL-oro drag suite -! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography -! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 +! related to GSL-oro drag suite +! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography +! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 ! FV3GFS_io.F90: if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & ! FV3GFS_io.F90: Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then ! FV3GFS_io.F90: if ( (Model%gwd_opt==3 .or. Model%gwd_opt==33) .or. & ! FV3GFS_io.F90: ( (Model%gwd_opt==2 .or. Model%gwd_opt==22) .and. & ! ! gwd_opt=1 -current 14-element GFS-EMC subgrid-oro input -! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input +! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input ! GSL uses the gwd_opt flag to control "extra" diagnostics (22 and 33) -! CCPP may use gwd_opt to determine 14 or 24 variables for the input +! CCPP may use gwd_opt to determine 14 or 24 variables for the input ! but at present you work with "nmtvr" ! GFS_GWD_generic.F90: integer, intent(in) :: im, levs, nmtvr !GFS_GWD_generic.F90: real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) @@ -136,7 +136,7 @@ subroutine ugwpv1_gsldrag_init ( & !GFS_GWD_generic.F90: elseif (nmtvr == 10) then ???? !GFS_GWD_generic.F90: elseif (nmtvr == 6) then ???? !GFS_GWD_generic.F90: elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp gwd_opt=2,3 -! +! ! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 ! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp !============================================================================== @@ -156,25 +156,25 @@ subroutine ugwpv1_gsldrag_init ( & return end if -! +! if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then - print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 - print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only + print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 + print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only write(errmsg,'(*(a))') " the CIRES CCPP-suite does not & - support schemes " + support schemes " errflg = 1 - return + return endif -! +! if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then - + print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only - print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl + print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & - support with but has Logic error" + support with but has Logic error" errflg = 1 - return + return endif !========================== ! @@ -191,64 +191,64 @@ subroutine ugwpv1_gsldrag_init ( & cpd = con_cp rd = con_rd rv = con_rv - fv = con_fvirt - - grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav + fv = con_fvirt + + grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav rdi = 1.0 / rd ; rcpd = 1./cpd; rcpd2 = 0.5/cpd - gor = grav/rd + gor = grav/rd gr2 = grav*gor grcp = grav*rcpd gocp = grcp - rcpdl = cpd*rgrav + rcpdl = cpd*rgrav grav2cpd = grav*grcp - - pi2 = 2.*pi ; pih = .5*pi + + pi2 = 2.*pi ; pih = .5*pi rad_to_deg=180.0/pi deg_to_rad=pi/180.0 - + bnv2min = (pi2/1800.)*(pi2/1800.) bnv2max = (pi2/30.)*(pi2/30.) - dw2min = 1.0 + dw2min = 1.0 velmin = sqrt(dw2min) minvel = 0.5 - + omega2 = 2.*omega1 omega3 = 3.*omega1 - + hpscale = 7000. ; hpskm = hpscale*1.e-3 rhp = 1./hpscale - rhp2 = 0.5*rhp; rh4 = 0.25*rhp + rhp2 = 0.5*rhp; rh4 = 0.25*rhp rhp4 = rhp2 * rhp2 - khp = rhp* rd/cpd + khp = rhp* rd/cpd mkzmin = pi2/80.0e3 mkz2min = mkzmin*mkzmin mkzmax = pi2/500. mkz2max = mkzmax*mkzmax - cdmin = 2.e-2/mkzmax - + cdmin = 2.e-2/mkzmax + rcpdt = rcpd/dtp if ( do_ugwp_v1 ) then call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & - con_p0, dtp, errmsg, errflg) + con_p0, dtp, errmsg, errflg) end if - + if (me == master) then print *, ' ccpp: ugwpv1_gsldrag_init ' - - print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 - print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl - print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss - print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd - - print *, ' ccpp: ugwpv1_gsldrag_init ' + + print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 + print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl + print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss + print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd + + print *, ' ccpp: ugwpv1_gsldrag_init ' endif - - - is_initialized = .true. - + + + is_initialized = .true. + end subroutine ugwpv1_gsldrag_init @@ -303,7 +303,7 @@ end subroutine ugwpv1_gsldrag_finalize !! !> \section gen_ugwpv1_gsldrag CIRES UGWP Scheme General Algorithm !! @{ - subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & + subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & @@ -316,22 +316,22 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & dudt_oss, dvdt_oss, du_osscol, dv_osscol, & dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & - dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & - tau_ogw, tau_ngw, tau_oss, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & + tau_ogw, tau_ngw, tau_oss, & zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & - lprnt, ipr, errmsg, errflg) + lprnt, ipr, errmsg, errflg) ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside ! ! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta ! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 -! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" !######################################################################## -! - +! + use ugwp_common, only : con_pi => pi, con_g => grav, con_rd => rd, & con_rv => rv, con_cp => cpd, con_fv => fv, & con_rerth => arad, con_omega => omega1, rgrav @@ -340,7 +340,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Preference use (im,levs) rather than (:,:) to avoid memory-leaks ! that found in Nov-Dec 2020 -! order array-description control-logical +! order array-description control-logical ! other in-variables ! out-variables ! local-variables @@ -349,17 +349,17 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! ! interface variables - logical, intent(in) :: ldiag3d, lssav - logical, intent(in) :: flag_for_gwd_generic_tend + logical, intent(in) :: ldiag3d, lssav + logical, intent(in) :: flag_for_gwd_generic_tend logical, intent(in) :: lprnt - + integer, intent(in) :: ipr - + ! flags for choosing combination of GW drag schemes to run - - logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd - logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp - logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes + + logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd + logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp + logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes integer, intent(in) :: me, master, im, levs, ntrac,lonr real(kind=kind_phys), intent(in) :: dtp, fhzero @@ -369,9 +369,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd integer, intent(in) :: gwd_opt !gwd_opt and nmtvr are "redundant" controls integer, intent(in) :: nmtvr real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! for gsl_drag - + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma - + real(kind=kind_phys), intent(in), dimension(im) :: elvmax real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 @@ -383,30 +383,30 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !===== ! real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & ! con_rv, con_rerth, con_fvirt -! grids +! grids real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area -! State vars + PBL/slmsk +rain +! State vars + PBL/slmsk +rain 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 integer, intent(in), dimension(im) :: kpbl - + real(kind=kind_phys), intent(in), dimension(im) :: rain - real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk + real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk ! ! moved to GFS_phys_time_vary ! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau -! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau - real(kind=kind_phys), intent(in), dimension(im) :: tau_amf - +! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau + real(kind=kind_phys), intent(in), dimension(im) :: tau_amf + !Output (optional): real(kind=kind_phys), intent(out), dimension(im) :: & - du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & - du_osscol, dv_osscol, du_ofdcol, dv_ofdcol + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol ! ! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) ! du_ngwcol, dv_ngwcol @@ -420,12 +420,12 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw - - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw - + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw + real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw -! -! +! +! real(kind=kind_phys), intent(inout), dimension(im, levs) :: dudt, dvdt, dtdt ! @@ -435,7 +435,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw - + real(kind=kind_phys), intent(out), dimension(im) :: rdxzb ! for stoch phys. mtb-level @@ -445,22 +445,22 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! local variables integer :: i, k - real(kind=kind_phys), dimension(im) :: sgh30 + 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 !------------ ! ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init -! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa +! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa ! ! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 !------------ ! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 ! switches that activate impact of OGWs and NGWs - + ! integer :: nmtvr_temp - + 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 @@ -476,45 +476,45 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Initialize CCPP error handling variables - + errmsg = '' errflg = 0 ! 1) ORO stationary GWs ! ------------------ -! +! ! for all oro-suites can uze geo-meters having "hpbl" -! +! ! ! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust ! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" ! zmeti = phii* rgrav zmet = phil* rgrav - + !=============================================================== ! ORO-diag - - dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. - dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. - - dusfcg (:) = 0. ; dvsfcg(:) =0. - - du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. - du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. - -! - dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. - -! ngw+ogw - diag - - dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. + + dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. + dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. + + dusfcg (:) = 0. ; dvsfcg(:) =0. + + du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. + du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. + +! + dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. + +! ngw+ogw - diag + + dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. ! source fluxes - - tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. - + + tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. + ! launch layers - + zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. !=============================================================== ! diag tendencies due to all-SSO schemes (ORO-physics) @@ -525,10 +525,10 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd Pdvdt(i,k) = 0.0 Pdudt(i,k) = 0.0 Pdtdt(i,k) = 0.0 - Pkdis(i,k) = 0.0 + Pkdis(i,k) = 0.0 enddo enddo -! +! ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd @@ -539,7 +539,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd ! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol ! dusfcg, dvsfcg -! +! ! call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & ugrs,vgrs,tgrs,q1, & @@ -556,33 +556,33 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd 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) -! +! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol -! -! if (kdt <= 2 .and. me == master) then -! print *, ' unified drag_suite_run ', kdt -! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 -! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 -! -! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 -! -! if (gwd_opt == 22 .or. gwd_opt == 33) then -! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 -! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 -! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 -! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 -! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 -! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 -! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 -! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 -! endif -! endif - - else +! +! if (kdt <= 2 .and. me == master) then +! print *, ' unified drag_suite_run ', kdt +! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! +! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! +! if (gwd_opt == 22 .or. gwd_opt == 33) then +! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 +! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 +! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 +! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 +! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 +! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 +! endif +! endif + + else ! ! not gsldrag oro-scheme for example "do_ugwp_v1_orog_only" -! - +! + if ( do_ugwp_v1_orog_only ) then ! ! for TOFD we use now "varss" of GSL-drag /not sgh30=abs(oro-oro_f)/ @@ -591,38 +591,38 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! OROGW_V1 introduce "orchestration" between OGW-effects and Mountain Blocking ! it starts to examines options for the Scale-Aware (SA)formulation of SSO-effects ! if ( me == master .and. kdt == 1) print *, ' bf orogw_v1 nmtvr=', nmtvr, ' do_tofd=', do_tofd - + if (gwd_opt ==1 )sgh30 = 0.15*hprime ! portion of the mesoscale SSO (~[oro_unfilt -oro_filt) if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run - + call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & xlat_d, sinlat, coslat, area, & cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & - sigma, gamma, elvmax, sgh30, kpbl, ugrs, & - vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & - Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & + sigma, gamma, elvmax, sgh30, kpbl, ugrs, & + vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & + Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_ofdcol, dv_ofdcol, errmsg,errflg ) -! +! ! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms ! ! ! if (kdt <= 2 .and. me == master) then -! -! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr -! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 -! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 -! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 -! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 -! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 -! endif - - +! +! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr +! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! endif + + end if ! -! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections +! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections ! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs @@ -633,7 +633,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - ENDIF + ENDIF ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Begin non-stationary GW schemes @@ -641,54 +641,54 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (do_ugwp_v1) then - -!================================================================== -! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) + +!================================================================== +! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) ! ! 2020 updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs -!================================================================== - +!================================================================== + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) - y4 = jdat(1); month = jdat(2); day = jdat(3) -! -! hour = jdat(5) + 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.) - - - call calendar_ugwp(y4, month, day, ddd_ugwp) + + + call calendar_ugwp(y4, month, day, ddd_ugwp) curdate = y4*1000 + ddd_ugwp -! +! call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & - tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) - + tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & zmet, zmeti,prslk, xlat_d, sinlat, coslat, & dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) -! +! ! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt ! ! if (me == master .and. kdt <= 2) then ! print * ! write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' ! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' -! print * -! -! print *, ' ugwp_v1 ', kdt -! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 -! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 -! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 +! print * +! +! print *, ' ugwp_v1 ', kdt +! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 +! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 +! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 ! endif - + end if ! do_ugwp_v1 - + ! ! GFS-style diag dt3dt(:.:, 1:14) time-averaged -! +! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im @@ -698,21 +698,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - + ! ! get total sso-OGW + NGW ! dudt_gw = Pdudt +dudt_ngw dvdt_gw = Pdvdt +dvdt_ngw - dtdt_gw = Pdtdt +dtdt_ngw - kdis_gw = Pkdis +kdis_ngw + dtdt_gw = Pdtdt +dtdt_ngw + kdis_gw = Pkdis +kdis_ngw ! -! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) +! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) ! dudt = dudt + dudt_ngw - dvdt = dvdt + dvdt_ngw - dtdt = dtdt + dtdt_ngw - + dvdt = dvdt + dvdt_ngw + dtdt = dtdt + dtdt_ngw + end subroutine ugwpv1_gsldrag_run !! @} !>@} From ea77544735b4c07ac59ee9a477f4e435eaa42569 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 11 Feb 2021 15:54:52 -0700 Subject: [PATCH 14/16] physics/ugwpv1_gsldrag.F90: adjust formatting --- physics/ugwpv1_gsldrag.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 24ab2b2d1..87cbbb853 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -69,7 +69,7 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & - con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & 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, do_ugwp_v1_w_gsldrag, errmsg, errflg) From 04ecde307c086c8ff49105757a506ccdfc561457 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 12 Feb 2021 15:02:42 -0700 Subject: [PATCH 15/16] Bugfix in physics/ugwpv1_gsldrag.F90, 3d diagnostic arrays may not be allocated --- physics/ugwpv1_gsldrag.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 87cbbb853..00fd42dbd 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -433,8 +433,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! Version of COORDE updated by CCPP-dev for time-aver ! - real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw - real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw From 8e4caf10a39ac7530e7c0eabc0aa1e0dd8deb959 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 16 Feb 2021 07:20:08 -0700 Subject: [PATCH 16/16] Bugfix in physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5ecc9d8a3..3e8e987c7 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -681,6 +681,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%dtdt_gw) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%kdis_gw) if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_obl ', Diag%dvdt_obl ) @@ -697,7 +698,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) else - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw) end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) @@ -1264,7 +1265,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb )