diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 index 09c969162..2ab0fb37a 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic.F90 @@ -83,7 +83,7 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = 0.0 clx(:,3) = 0.0 clx(:,4) = 0.0 - elseif (nmtvr == 24) then ! GSD_drag_suite + elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) @@ -93,6 +93,10 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = mntvar(:,8) clx(:,3) = mntvar(:,9) clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) varss(:) = mntvar(:,15) ocss(:) = mntvar(:,16) oa4ss(:,1) = mntvar(:,17) diff --git a/physics/cires_orowam2017.F90 b/physics/cires_orowam2017.F90 new file mode 100644 index 000000000..d5fda5cc0 --- /dev/null +++ b/physics/cires_orowam2017.F90 @@ -0,0 +1,354 @@ +module cires_orowam2017 + + +contains + + + subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & + & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & + & grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + & sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys +! + implicit none + + integer :: im, levs + integer :: npt + integer :: kdt, me, master + integer :: kref(im), ipt(im) + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, & + & hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: & + & u1, v1, t1, bn2, rho, prsl, del + real(kind=kind_phys), intent(in) :: 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 + real(kind=kind_phys) :: belps, aelps, nhills, selps +! +! multiwave oro-spectra +! locals +! + integer :: i, j, k, isp, iw + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real :: akx(nworo), cxoro(nworo), akx2(nworo) + real :: aspkx(nworo), c2f2(nworo) , cdf2(nworo) + real :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real :: tau_kx(nworo),taub_kx(nworo) + real, dimension(nworo, levs+1) :: wrms, akzw + + real :: tauz(levs+1), rms_wind(levs+1) + real :: wave_act(nworo,levs+1) + + real :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real :: rayf, kturb + real :: uz, bv, bv2,kxsp, fcor2, cf2 + + real :: fdis + real :: wfdm, wfdt, wfim, wfit + real :: betadis, betam, betat, kds, cx, rhofac + real :: etwk, etws, tauk, cx2sat + real :: cdf1, tau_norm +! +! mean flow +! + real, dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + + integer :: nw, nzi, ksrc + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then +771 format( 'vay-oro19 ', 3(2x,F8.3)) + write(6,771) & + & maxval(tau_kx)*maxval(taub)*1.e3, & + & minval(tau_kx), maxval(tau_kx) + endif +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & + & prsi(j,:), prsL(j,:), 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) +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +!23456 + end subroutine oro_wam_2017 +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & grav, con_rd, & + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + + use ugwp_common_v1 , only : velmin, dw2min + implicit none + + integer :: nz, nzi + real, dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real, dimension(nz ) :: bn2 ! define at the interfaces + real, dimension(nz+1) :: pint + real :: xn, yn + real,intent(in) :: grav, con_rd +! output + + real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real :: zgrow, zmet, rdpm, ritur, kmol, w1 + real :: rgrav, rdi +! paremeters + real, parameter :: hps = 7000., rpspa = 1.e-5 + real, parameter :: rhps=1.0/hps + real, parameter :: h4= 0.25/hps + real, parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real, parameter :: lturb = 30. , uturb = 150.0 + real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + kalp(1:nzi) = 2.e-7 ! radiative damping + + 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 + +end module cires_orowam2017 diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index f24ae39ae..21b331041 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -155,7 +155,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & - rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + con_omega, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, errmsg, errflg) @@ -192,7 +192,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, con_omega real(kind=kind_phys), intent(in), dimension(im) :: rain @@ -245,8 +245,8 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & - me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - dudt_mtb, dudt_ogw, dudt_tms) + me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) else ! calling old GFS gravity wave drag as is diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index ca1e573ba..133cd5b1d 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -806,6 +806,15 @@ kind = kind_phys intent = in optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [rain] standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep long_name = total rain at this time step diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 new file mode 100644 index 000000000..4258680ea --- /dev/null +++ b/physics/cires_ugwp_initialize_v1.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_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_v1.F90 b/physics/cires_ugwp_module_v1.F90 new file mode 100644 index 000000000..9b245ed11 --- /dev/null +++ b/physics/cires_ugwp_module_v1.F90 @@ -0,0 +1,673 @@ + +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 :: knob_ugwp_tlimb = .true. +! + real :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes +! +! tune-ups for qbo +! + real :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs + real :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians + real :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing + real :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO + real :: knob_ugwp_qbotau = 10. ! relaxation time scale in days + real :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing + real :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing + character(len=8) :: knob_ugwp_orosolv='pss-1986' + + character(len=255) :: ugwp_qbofile = 'qbo_zmf_2009_2018.nc' + character(len=255) :: ugwp_taufile = 'ugwp_limb_tau.nc' + +! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! +! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' +! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' + +! integer, parameter :: ny_tab=73, nt_tab=14 +! real, parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. +! real :: days_tab(nt_tab), lat_tab(ny_tab) +! real :: abmf_tab(ny_tab,nt_tab) + + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + real :: ugwp_effac + +! + integer :: knob_ugwp_version = 0 + integer :: launch_level = 55 +! + namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & + knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & + knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & + knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & + knob_ugwp_qbolev, knob_ugwp_qbosin, knob_ugwp_qbotav, knob_ugwp_qboamp, knob_ugwp_qbotau, & + knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_tlimb, knob_ugwp_orosolv + +!&cires_ugwp_nml +! knob_ugwp_solver=2 +! knob_ugwp_source=1,1,1,0 +! knob_ugwp_wvspec=1,32,32,32 +! knob_ugwp_azdir =2, 4, 4,4 +! knob_ugwp_stoch =0, 0, 0,0 +! knob_ugwp_effac=1, 1, 1,1 +! knob_ugwp_doaxyz=1 +! knob_ugwp_doheat=1 +! knob_ugwp_dokdis=0 +! knob_ugwp_ndx4lh=4 +!/ +! +! allocatable arrays, initilized during "cires_ugwp_init" & +! released during "cires_ugwp_finalize" +! + real, allocatable :: kvg(:), ktg(:), krad(:), kion(:) + real, allocatable :: zkm(:), pmb(:) + real, allocatable :: rfdis(:), rfdist(:) + integer :: levs_rf + real :: pa_rf, tau_rf +! +! tabulated GW-sources +! + integer :: ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t + real, allocatable :: ugwp_taulat(:), ugwp_qbolat(:) + real, allocatable :: tau_limb(:,:), days_limb(:) + real, allocatable :: uzmf_merra(:,:,:), days_merra(:), pmb127(:) + real, allocatable :: uqboe(:,:) + real, allocatable :: days_y4ddd(:), zkm127(:) + real, allocatable :: tau_qbo(:), stau_qbo(:) + integer,allocatable :: days_y4md(:) + real, allocatable :: vert_qbo(:) + +! +! limiters +! + real, parameter :: latqbo =20., widqbo=15., taurel = 21600. + integer, parameter :: kz2 = 127-7, kz1= 127-49, kz5=5 ! 64km - 18km +! + +!====================================================================== + real, parameter :: F_coriol=1 ! Coriolis effects + real, parameter :: F_nonhyd=1 ! Nonhydrostatic waves + real, parameter :: F_kds =0 ! Eddy mixing due to GW-unstable below + real, parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw + real, parameter :: iPr_turb =1./3., iPr_mol =1.95 + real, parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 + real, parameter :: khp = 0.287*rhp1 ! R/Cp/Hp + real, parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model + + contains +! +! ----------------------------------------------------------------------- +! +! init of cires_ugwp (_init) called from CCPP cap file +! +! ----------------------------------------------------------------------- + + + + subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, 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 new file mode 100644 index 000000000..4b2a19884 --- /dev/null +++ b/physics/cires_ugwp_ngw_utils.F90 @@ -0,0 +1,73 @@ +module cires_ugwp_ngw_utils + + +contains + + + subroutine tau_limb_advance(me, master, im, levs, ddd, curdate, & + j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + + + + use machine, only : kind_phys + + use cires_ugwp_module_v1, only : ntau_d1y, ntau_d2t + use cires_ugwp_module_v1, only : ugwp_taulat, days_limb, tau_limb + +! use cires_ugwp_module, only : ugwp_qbolat, days_merra, pmb127, days_y4md, days_y4ddd +! use cires_ugwp_module, only : tau_qbo, stau_qbo, uqboe, u2 => uzmf_merra + + implicit none + + integer, intent(in) :: me, master, im, levs, ddd, curdate, kdt + integer, intent(in), dimension(im) :: j1_tau, j2_tau + + real , intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau + + real, intent(out) :: tau_sat(im) + + integer :: i, j1, j2, k, it1, it2, iday + real :: tem, tx1, tx2, w1, w2, day2, day1, ddx + integer :: yr1, yr2 +! + integer :: iqbo1=1 +! + + + + it1 = 2 + do iday=1, ntau_d2t + if (float(ddd) .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + stop + endif + w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) + tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) + tau_sat(i) = tx1*w1 + w2*tx2 + enddo + + if (me == master ) then + print*, maxval(tau_limb), minval(tau_limb), ' tau_limb ' + print*, ntau_d2t + print*, days_limb(1) , days_limb(ntau_d2t) , ddd, ' days-taulimb ' + print*, 'curdate ', curdate + print*, maxval(tau_sat), minval(tau_sat), ' tau_sat_fv3 ' + endif + return + + end subroutine tau_limb_advance + +end module cires_ugwp_ngw_utils diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 new file mode 100644 index 000000000..fd692a825 --- /dev/null +++ b/physics/cires_ugwp_orolm97_v1.F90 @@ -0,0 +1,1008 @@ +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 new file mode 100644 index 000000000..46a5fb833 --- /dev/null +++ b/physics/cires_ugwp_solv2_v1_mod.F90 @@ -0,0 +1,829 @@ +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_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 new file mode 100644 index 000000000..8cfd57cb7 --- /dev/null +++ b/physics/cires_ugwp_triggers_v1.F90 @@ -0,0 +1,584 @@ +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_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 new file mode 100644 index 000000000..852c114b0 --- /dev/null +++ b/physics/cires_vert_orodis_v1.F90 @@ -0,0 +1,1047 @@ +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/docs/library.bib b/physics/docs/library.bib index dd2b2042e..b96226e04 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3197,3 +3197,44 @@ @inproceedings{yudin_et_al_2019 Booktitle = {Space Weather Workshop}, Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, Year = {2019}} + +@article{kim_and_doyle_2005, + Author = {Y.-J. Kim and J.D. Arakawa}, + Doi = {10.1256/qj.04.160}, + Url = {https://doi.org/10.1256/qj.04.160}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1893-1921}, + Title = {Extension of an orographic-drag parametrization scheme to incorporate orographic inisotropy and flow blocking}, + Volume = {131}, + Year = {2005}} + +@article{steeneveld_et_al_2008, + Author = {Steeneveld, G. J.,A.A. M. Holtslag, C. J. Nappo, B. J. H. van de Wiel, and L. Mahrt}, + Doi = {10.1175/2008JAMC1816.1}, + Url = {https://doi.org/10.1175/2008JAMC1816.1}, + Journal = {J. Appl. Meteor.}, + Pages = {2518-2530}, + Title = {Exploring the possible role of small-scale terrain drag on stable boundary layers over land}, + Volume = {47}, + Year = {2008}} + +@article{tsiringakis_et_al_2017, + Author = {Tsiringakis,A., G. J. Steeneveld, and A.A. M. Holtslag}, + Doi = {10.1002/qj.3021}, + Url = {https://doi.org/10.1002/qj.3021}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1504-1516}, + Title = {Small-scale orographic gravity wave drag in stable boundary layers and its impact on synoptic systems and near-surface meteorology}, + Volume = {143}, + Year = {2017}} + +@article{beljaars_et_al_2004, + Author = {Beljaars, A.C.M., A.R.Brown, and N.Wood}, + Doi = {10.1256/qj.03.73}, + Url = {https://doi.org/10.1256/qj.03.73}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1327-1347}, + Title = {A new parametrization of turbulent orographic form drag}, + Volume = {130}, + Year = {2004}} + diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 55ef9c268..0b0ef03a0 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -186,13 +186,6 @@ end subroutine drag_suite_init !! !> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm !> @{ -! subroutine drag_suite_run( & -! & IM,IX,KM,A,B,C,U1,V1,T1,Q1,KPBL, & -! & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & -! & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & -! & DUSFC,DVSFC,G, CP, RD, RV, IMX, & -! & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, errmsg, errflg) -! subroutine drag_suite_run( & & IM,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & @@ -206,7 +199,9 @@ subroutine drag_suite_run( & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & - & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + & lprnt, ipr, rdxzb, dx, gwd_opt, & + & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + & errmsg, errflg ) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -243,6 +238,15 @@ subroutine drag_suite_run( & ! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating ! gsd_diss_ht_opt = 0: dissipation heating off ! gsd_diss_ht_opt = 1: dissipation heating on +! 2020-08-25 Michael Toy changed logic control for drag component selection +! for CCPP. +! Namelist options: +! do_gsl_drag_ls_bl - logical flag for large-scale GWD + blocking +! do_gsl_drag_ss - logical flag for small-scale GWD +! do_gsl_drag_tofd - logical flag for turbulent form drag +! Compile-time options (same as before): +! gwd_opt_ls = 0 or 1: large-scale GWD +! gwd_opt_bl = 0 or 1: blocking drag ! ! References: ! Hong et al. (2008), wea. and forecasting @@ -363,12 +367,16 @@ subroutine drag_suite_run( & !------------------------------------------------------------------------- ! Flags to regulate the activation of specific components of drag suite: ! Each component is tapered off automatically as a function of dx, so best to -! keep them activated (=1). - integer, parameter :: & - gwd_opt_ls = 1, & ! large-scale gravity wave drag - gwd_opt_bl = 1, & ! blocking drag - gwd_opt_ss = 1, & ! small-scale gravity wave drag (Steeneveld et al. 2008) - gwd_opt_fd = 1, & ! form drag (Beljaars et al. 2004, QJRMS) +! keep them activated (.true.). + logical, intent(in) :: & + do_gsl_drag_ls_bl, & ! large-scale gravity wave drag and blocking + do_gsl_drag_ss, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + do_gsl_drag_tofd ! form drag (Beljaars et al. 2004, QJRMS) + +! Additional flags + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag gsd_diss_ht_opt = 0 ! Parameters for bounding the scale-adaptive variability: @@ -616,7 +624,7 @@ subroutine drag_suite_run( & enddo enddo ! - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do i = its,im dusfc_ls(i) = 0.0 dvsfc_ls(i) = 0.0 @@ -759,7 +767,8 @@ subroutine drag_suite_run( & ! ! END INITIALIZATION; BEGIN GWD CALCULATIONS: ! -IF ( ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & +IF ( (do_gsl_drag_ls_bl).and. & + ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & (ls_taper .GT. 1.E-02) ) THEN !==== ! !--- saving richardson number in usqj for migwdi @@ -895,7 +904,7 @@ subroutine drag_suite_run( & endif enddo -ENDIF ! (gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1) +ENDIF ! (do_gsl_drag_ls_bl).and.((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) !========================================================= ! add small-scale wavedrag for stable boundary layer @@ -907,7 +916,7 @@ subroutine drag_suite_run( & utendwave=0. vtendwave=0. ! - IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + IF ( (do_gsl_drag_ss).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running small-scale gravity wave drag" ! ! declaring potential temperature @@ -1008,7 +1017,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) @@ -1019,12 +1028,12 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_ss == 1 +ENDIF ! if (do_gsl_drag_ss) !================================================================ ! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): !================================================================ -IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_tofd).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running form drag" utendform=0. @@ -1066,7 +1075,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_fd(i,k) = utendform(i,k) @@ -1077,10 +1086,11 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_fd == 1 +ENDIF ! if (do_gsl_drag_tofd) !======================================================= ! More for the large-scale gwd component -IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl).and. & + (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running large-scale gravity wave drag" ! ! now compute vertical structure of the stress. @@ -1148,7 +1158,8 @@ subroutine drag_suite_run( & !=============================================================== !COMPUTE BLOCKING COMPONENT !=============================================================== -IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running blocking drag" do i = its,im @@ -1194,7 +1205,8 @@ subroutine drag_suite_run( & ENDIF ! end blocking drag !=========================================================== -IF ( (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy ! @@ -1264,7 +1276,7 @@ subroutine drag_suite_run( & dvsfc(i) = (-1./g*rcs) * dvsfc(i) enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) @@ -1279,9 +1291,9 @@ subroutine drag_suite_run( & enddo endif -ENDIF +ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls.EQ.1 .OR. gwd_opt_bl.EQ.1) -if (gwd_opt == 33) then +if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then ! Finalize dusfc and dvsfc diagnostics do i = its,im dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index ba15719c1..a69cd1f47 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -591,6 +591,30 @@ type = integer intent = in optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index f573c8776..c47079992 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,4 +1,4 @@ -!!23456 +! module sso_coorde ! ! specific to COORDE-2019 project OGW switches/sensitivity @@ -31,7 +31,8 @@ subroutine cires_ugwp_driver_v0(me, master, ! (similar to WAM-2017) !----------------------------------------------------------- use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv + use physcons, only : con_cp, con_g, con_rd, con_rv, & + con_omega use ugwp_wmsdis_init, only : tamp_mpa, ilaunch use sso_coorde, only : pgwd, pgwd4, debugprint @@ -121,6 +122,7 @@ subroutine cires_ugwp_driver_v0(me, master, & SIGMA, GAMM, ELVMAX, & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, & cdmbgwd(1:2), me, master, rdxzb, + & con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & du3dt_mtb, du3dt_ogw, du3dt_tms) ! @@ -287,7 +289,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, & DUSFC, DVSFC, xlatd, sinlat, coslat, sparea, - $ cdmbgwd, me, master, rdxzb, + & cdmbgwd, me, master, rdxzb, con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & dudt_mtb, dudt_ogw, dudt_tms) !---------------------------------------- @@ -341,6 +343,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys), intent(in) :: ELVMAXD(IM), THETA(IM) real(kind=kind_phys), intent(in) :: vSIGMA(IM), vGAMMA(IM) real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) + + real(kind=kind_phys), intent(in) :: con_g, con_omega !output -phys-tend real(kind=kind_phys),dimension(im,km),intent(out) :: @@ -1066,6 +1070,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, + & con_g, con_omega, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 new file mode 100644 index 000000000..fda887f3e --- /dev/null +++ b/physics/unified_ugwp.F90 @@ -0,0 +1,736 @@ +!> \file unified_ugwp.F90 +!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: +!! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f +!! b) the v0 cires ugwp non-stationary GWD scheme +!! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: +!! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales +!! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) +!! b) small-scale gravity wave drag scheme -- active typically in stable PBL at horizontal grid resolutions down to ~1km +!! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) +!! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km +!! (Beljaars et al, 2004 \cite beljaars_et_al_2004) +!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) +!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "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 unified_ugwp scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD +!! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag +!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only +!! Note that only one "large-scale" scheme can be activated at a time. +!! + +module unified_ugwp + + use machine, only: kind_phys + + use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + + use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp + + use gwdps, only: gwdps_run + + use drag_suite, only: drag_suite_run + + use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 + + use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 + + ! use cires_ugwp_ngw_utils, only: tau_limb_advance + + use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 + + implicit none + + private + + public unified_ugwp_init, unified_ugwp_run, unified_ugwp_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the unified UGWP +!> \section arg_table_unified_ugwp_init Argument Table +!! \htmlinclude unified_ugwp_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & + con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & + do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, errmsg, errflg) + +!---- initialization of unified_ugwp + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + character(len=*), intent (in) :: input_nml_file(:) + integer, intent (in) :: logunit + integer, intent(in) :: jdat(8) + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + real(kind=kind_phys), intent (in) :: ak(:), bk(:) + real(kind=kind_phys), intent (in) :: dtp + real(kind=kind_phys), intent (in) :: cdmbgwd(4), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes + real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in + real(kind=kind_phys), intent (in) :: con_p0, 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 + + character(len=*), intent (in) :: fn_nml2 + !character(len=*), parameter :: fn_nml='input.nml' + + integer :: ios + logical :: exists + real :: dxsg + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + ! Test to make sure that at most only one large-scale/blocking + ! orographic drag scheme is chosen + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & + do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & + do_ugwp_v1_orog_only)) .or. & + (do_gsl_drag_ls_bl.and.(do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v1.and.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: Only one large-scale& + &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& + &do_gsl_drag_ls_bl,do_ugwp_v1 or & + &do_ugwp_v1_orog_only) can be chosen" + errflg = 1 + return + + end if + + + if (is_initialized) return + + + if ( do_ugwp_v0 ) then + ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) + if (cdmbgwd(3) > 0.0) then + call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + else + write(errmsg,'(*(a))') "Logic error: cires_ugwp_mod_init called but & + &do_ugwp_v0 is true and cdmbgwd(3) <= 0" + errflg = 1 + return + end if + 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 + + +! ----------------------------------------------------------------------- +! finalize of unified_ugwp (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP + +!> \section arg_table_unified_ugwp_finalize Argument Table +!! \htmlinclude unified_ugwp_finalize.html +!! + + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) + + implicit none +! + logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() + + if ( do_ugwp_v1 ) call cires_ugwp_finalize() + + is_initialized = .false. + + end subroutine unified_ugwp_finalize + + +! ----------------------------------------------------------------------- +! originally from ugwp_driver_v0.f +! driver of cires_ugwp (_driver) +! ----------------------------------------------------------------------- +! driver is called after pbl & before chem-parameterizations +! ----------------------------------------------------------------------- +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +! ----------------------------------------------------------------------- +!>@brief These subroutines and modules execute the CIRES UGWP Version 0 +!>\defgroup unified_ugwp_run Unified Gravity Wave Physics General Algorithm +!> @{ +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! +!! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. +!! +!> \section arg_table_unified_ugwp_run Argument Table +!! \htmlinclude unified_ugwp_run.html +!! +!> \section gen_unified_ugwp CIRES UGWP Scheme General Algorithm +!! @{ + subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & + lonr, oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss,dx,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl,dusfc_ss, & + dvsfc_ss,dusfc_fd,dvsfc_fd,dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,br1,hpbl,slmsk, & + do_tofd, ldiag_ugwp, cdmbgwd, jdat, xlat, xlat_d, sinlat, coslat, area, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & + del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & + dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt, dvdt, dtdt, rdxzb, con_g, con_omega, con_pi, con_cp, con_rd, con_rv, & + con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr + integer, intent(in) :: gwd_opt + integer, intent(in), dimension(im) :: kpbl + real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,oa4ss,ol4ss,dx + logical, intent(in) :: flag_for_gwd_generic_tend + ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii + real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 + real(kind=kind_phys), intent(in) :: dtp, fhzero, cdmbgwd(4) + integer, intent(in) :: jdat(8) + logical, intent(in) :: do_tofd, ldiag_ugwp + +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + + real(kind=kind_phys), intent(in) :: br1(im), & + & hpbl(im), & + & slmsk(im) + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + + ! These arrays are only allocated if ldiag=.true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw + logical, intent(in) :: ldiag3d, lssav + + ! These arrays only allocated if ldiag_ugwp = .true. + real(kind=kind_phys), intent(out), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms + + real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt + + real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & + con_rv, con_rerth, con_fvirt + + real(kind=kind_phys), intent(in), dimension(im) :: rain + + integer, intent(in) :: ntke + real(kind=kind_phys), intent(in), dimension(:,:) :: q_tke, dqdt_tke + + logical, intent(in) :: lprnt + integer, intent(in) :: ipr + + ! flags for choosing combination of GW drag schemes to run + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i, k + real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis + real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt + ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init + real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 + ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) + real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. + real(kind=kind_phys), parameter :: fw1_tau=1.0 + integer :: nmtvr_temp + + real(kind=kind_phys), dimension(:,:), allocatable :: tke + real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1 + + real(kind=kind_phys) :: inv_g + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers + real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces + + + ! ugwp_v1 local variables + integer :: y4, month, day, ddd_ugwp, curdate, curday + integer :: hour + real(kind=kind_phys) :: hcurdate, hcurday, fhour, fhrday + integer :: kdtrest + integer :: curday_ugwp + integer :: curday_save=20150101 + logical :: first_qbo=.true. + real :: hcurday_save =20150101.00 + save first_qbo, curday_save, hcurday_save + + + ! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 + real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! 1) ORO stationary GWs + ! ------------------ + + zlwb(:) = 0. + + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme + ! Note: In case of GSL drag_suite, this includes ss and tofd + + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd ) then + + call drag_suite_run(im,levs,dvdt,dudt,dtdt,ugrs,vgrs,tgrs,q1, & + kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & + kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & + ol4ss,theta,sigma,gamma,elvmax,dtaux2d_ls, & + dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss, & + dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,dusfcg, & + dvsfcg,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & + con_fvirt,con_pi,lonr, & + 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 = 0. + endif + + inv_g = 1./con_g + zmeti = phii*inv_g + zmet = phil*inv_g + + call gwdps_oro_v1 (im, levs, lonr, do_tofd, & + Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & + prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & + clx, theta, sigma, gamma, elvmax, & + con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & + con_rerth, con_fvirt, sgh30, DUSFCg, DVSFCg, & + xlat_d, sinlat, coslat, area,cdmbgwd(1:2), me, & + master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, du3dt_mtb, du3dt_ogw, du3dt_tms) + + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo + + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + + ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary + if ( nmtvr == 24 ) then ! gwd_opt = 2, 22, 3, or 33 + nmtvr_temp = 14 + else + nmtvr_temp = nmtvr + end if + + call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & + ugrs, vgrs, tgrs, q1, & + kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & + hprime, oc, oa4, clx, theta, sigma, gamma, & + elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, lonr, & + nmtvr_temp, cdmbgwd, me, lprnt, ipr, rdxzb, & + errmsg, errflg) + if (errflg/=0) return + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + if (ldiag_ugwp) then + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + end if + + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + Pdudt(i,k)*dtp + ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + Pdvdt(i,k)*dtp + ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + Pdtdt(i,k)*dtp + enddo + enddo + endif + + end if + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Begin non-stationary GW schemes + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! + ! ugwp_v0 non-stationary GW drag + ! + if (do_ugwp_v0) then + + if (cdmbgwd(3) > 0.0) then + + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing + call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + + if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then + if (cdmbgwd(4) > 0.0) then + allocate(turb_fac(im)) + do i=1,im + turb_fac(i) = 0.0 + enddo + if (ntke > 0) then + allocate(tke(im,levs)) + allocate(tem(im)) + tke(:,:) = q_tke(:,:) + dqdt_tke(:,:) * dtp + tem(:) = 0.0 + do k=1,(levs+levs)/3 + do i=1,im + turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) + tem(i) = tem(i) + del(i,k) + enddo + enddo + do i=1,im + turb_fac(i) = turb_fac(i) / tem(i) + enddo + deallocate(tke) + deallocate(tem) + endif + rfac = 86400000 / dtp + do i=1,im + tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + enddo + deallocate(turb_fac) + endif + do i=1,im + tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) + enddo + endif + + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_ngw, me, master, kdt) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) + !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) + !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) + !dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + enddo + enddo + + else ! .not.(cdmbgwd(3) > 0.0) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = Pdtdt(i,k) + gw_dudt(i,k) = Pdudt(i,k) + gw_dvdt(i,k) = Pdvdt(i,k) + gw_kdis(i,k) = Pkdis(i,k) + enddo + enddo + + endif ! cdmbgwd(3) > 0.0 + + if (pogw == 0.0) then + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + endif + +#if 0 + !============================================================================= + ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving + ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" + !============================================================================= + ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies + !------------------------------------------------------------------------------ + do k=1,levs + do i=1,im + ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + enddo + enddo + + call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) + gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked + gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked + gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked +#endif + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_cgw(i,k) = ldu3dt_cgw(i,k) + (gw_dudt(i,k) - Pdudt(i,k))*dtp + ldv3dt_cgw(i,k) = ldv3dt_cgw(i,k) + (gw_dvdt(i,k) - Pdvdt(i,k))*dtp + ldt3dt_cgw(i,k) = ldt3dt_cgw(i,k) + (gw_dtdt(i,k) - Pdtdt(i,k))*dtp + enddo + enddo + endif + + end if ! do_ugwp_v0 + + + ! + ! ugwp_v1 non-stationary GW drag + ! + if (do_ugwp_v1) then + +! -------- +! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing +! ---------------------------------------------- +!-------- +! GMAO GEOS-5/MERRA GW-forcing lat-dep +!-------- + call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) + + y4 = jdat(1); month = jdat(2); day = jdat(3) ; hour = jdat(5) + + ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. + fhour = (kdt-1)*dtp/3600. + fhrday = fhour/24. - nint(fhour/24.) + fhour = fhrday*24. + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp + curday = y4*10000 + month*100 + day + hcurdate = float(curdate) + fhrday + hcurday = float(curday) + fhrday +! + if (mod(fhour,fhzero) == 0 .or. first_qbo) then + + ! call tau_limb_advance(me, master, im, levs, ddd_ugwp, curdate, & + ! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + if (first_qbo) kdtrest = kdt + first_qbo = .false. + curday_save = curday + hcurday_save= hcurday + endif + + ! tau_ngw = fw1_tau*tau_ngw + tau_sat*(1.-fw1_tau) + +! goto 111 +! if (mod(fhour,fhzero) == 0 .or. first_qbo) then + +! call tau_qbo_advance(me, master, im, levs, ddd_ugwp, curdate, & +! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, j1_qbo, j2_qbo, & +! ddy_j1qbo, ddy_j2qbo, tau_sat, tau_qbo, uqbo, ax_qbo, kdt ) + + +! if (me == master) then +! print *, ' curday_save first_qbo ', curday, curday_save, kdt +! print *, ' hcurdays ', hcurdate, float(hour)/24. +! print *, jdat(5), jdat(6), jdat(7), (kdt-1)*dtp/3600., ' calendar ' +!! print *, ' curday curday_ugwp first_qbo ', hcurday, first_qbo +!! print *, ' vay_tau-limb U' , maxval(uqbo), minval(uqbo) +!! print *, ' vay_tau-limb TS' , maxval(tau_sat), minval(tau_sat) +!! print *, ' vay_tau-limb TQ' , maxval(tau_qbo), minval(tau_qbo) +! endif + + +! if (first_qbo) kdtrest = kdt +! first_qbo = .false. +! curday_save = curday +! hcurday_save= hcurday +! endif + + + + +! if (mod(kdt, 720) == 0 .and. me == master ) then +! print *, ' vay_qbo_U' , maxval(uqbo), minval(uqbo) , kdt +! endif + +! wqbo = dtp/taurel +! do k =1, levs +!! sdexpz = wqbo*vert_qbo(k) +! sdexpz = 0.25*vert_qbo(k) +! do i=1, im +!! if (dexpy(i) > 0.0) then +! dforc = 0.25 +!! ugrs(i,k) = ugrs(i,k)*(1.-dforc) + dforc*uqbo(i,levs+1-k) +!! tgrs(i,k) = tgrs(i,k)*(1.-dforc) + dforc*tqbo(i,levs+1-k) +!! endif +! enddo +! enddo + +! 111 continue + + + call cires_ugwp_solv2_v1(im, levs, dtp, & + tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + 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 +!! @} +!>@} +end module unified_ugwp diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta new file mode 100644 index 000000000..49f9365fd --- /dev/null +++ b/physics/unified_ugwp.meta @@ -0,0 +1,1360 @@ +[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 + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for opening namelist file + units = none + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=* + intent = in + optional = F +[logunit] + standard_name = iounit_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in + optional = F +[fn_nml2] + standard_name = namelist_filename + long_name = namelist filename for ugwp + units = none + dimensions = () + type = character + kind = len=* + intent = in + optional = F +[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 +[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 +[cgwf] + standard_name = multiplication_factors_for_convective_gravity_wave_drag + long_name = multiplication factor for convective GWD + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[pa_rf_in] + standard_name = pressure_cutoff_for_rayleigh_damping + long_name = pressure level from which Rayleigh Damping is applied + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tau_rf_in] + standard_name = time_scale_for_rayleigh_damping + long_name = time scale for Rayleigh damping in days + units = d + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_p0] + standard_name = standard_atmospheric_pressure + long_name = standard atmospheric pressure + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_finalize + type = scheme +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_run + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fhzero] + standard_name = hours_between_clearing_of_diagnostic_buckets + long_name = hours between clearing of diagnostic buckets + units = h + dimensions = () + type = real + kind = kind_phys +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[oro] + standard_name = orography + long_name = orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oro_uf] + standard_name = orography_unfiltered + long_name = unfiltered orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of topographic variables in GWD + units = count + dimensions = () + type = integer + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degree + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[varss] + standard_name = standard_deviation_of_subgrid_orography_small_scale + long_name = standard deviation of subgrid orography small scale + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oc1ss] + standard_name = convexity_of_subgrid_orography_small_scale + long_name = convexity of subgrid orography small scale + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oa4ss] + standard_name = asymmetry_of_subgrid_orography_small_scale + long_name = asymmetry of subgrid orography small scale + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4ss] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height small scale + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ls] + standard_name = x_momentum_tendency_from_large_scale_gwd + long_name = x momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ls] + standard_name = y_momentum_tendency_from_large_scale_gwd + long_name = y momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_bl] + standard_name = x_momentum_tendency_from_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_bl] + standard_name = y_momentum_tendency_from_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ss] + standard_name = x_momentum_tendency_from_small_scale_gwd + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ss] + standard_name = y_momentum_tendency_from_small_scale_gwd + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_fd] + standard_name = x_momentum_tendency_from_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_fd] + standard_name = y_momentum_tendency_from_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[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 +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sinlat] + standard_name = sine_of_latitude + long_name = sine of the grid latitude + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[coslat] + standard_name = cosine_of_latitude + long_name = cosine of the grid latitude + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between midlayers + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F + intent = out + optional = F +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_kdis] + standard_name = eddy_mixing_due_to_ugwp + long_name = eddy mixing due to UGWP + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_tms] + standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[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 +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[q_tke] + standard_name = turbulent_kinetic_energy + long_name = turbulent kinetic energy + units = J + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqdt_tke] + standard_name = tendency_of_turbulent_kinetic_energy_due_to_model_physics + long_name = turbulent kinetic energy tendency due to model physics + units = J s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[ldu3dt_ogw] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in x wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ogw] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in y wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ogw] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldu3dt_cgw] + standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in x wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_cgw] + standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in y wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_cgw] + standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag + long_name = cumulative change in temperature due to convective gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_gravity_wave_drag_tendency + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 new file mode 100644 index 000000000..39de4b475 --- /dev/null +++ b/physics/unified_ugwp_post.F90 @@ -0,0 +1,83 @@ +!> \file unified_ugwp_post.F90 +!! This file contains +module unified_ugwp_post + +contains + +!>\defgroup unified_ugwp_post unified_UGWP Scheme Post +!! @{ +!> \section arg_table_unified_ugwp_post_init Argument Table +!! + subroutine unified_ugwp_post_init () + end subroutine unified_ugwp_post_init + +!>@brief The subroutine initializes the unified UGWP + +!> \section arg_table_unified_ugwp_post_run Argument Table +!! \htmlinclude unified_ugwp_post_run.html +!! + + + + subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & + gw_dtdt, gw_dudt, gw_dvdt, tau_tofd, tau_mtb, tau_ogw, & + tau_ngw, zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & + tot_zmtb, tot_zlwb, tot_zogw, & + tot_tofd, tot_mtb, tot_ogw, tot_ngw, & + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtf + logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics + + real(kind=kind_phys), intent(in), dimension(:) :: zmtb, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(:) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_zmtb, tot_zlwb, tot_zogw + real(kind=kind_phys), intent(in), dimension(:,:) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zmtb + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *tau_tofd + tot_mtb = tot_mtb + dtf *tau_mtb + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_mtb + du3dt_tms = du3dt_tms + dtf *dudt_tms + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *gw_dudt + dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt + endif + + dtdt = dtdt + gw_dtdt + dudt = dudt + gw_dudt + dvdt = dvdt + gw_dvdt + + end subroutine unified_ugwp_post_run + +!> \section arg_table_unified_ugwp_post_finalize Argument Table +!! + subroutine unified_ugwp_post_finalize () + end subroutine unified_ugwp_post_finalize + +!! @} +end module unified_ugwp_post diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta new file mode 100644 index 000000000..501e91b8f --- /dev/null +++ b/physics/unified_ugwp_post.meta @@ -0,0 +1,321 @@ +[ccpp-table-properties] + name = unified_ugwp_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_run + type = scheme +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_tms] + standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tot_zmtb] + standard_name = time_integral_of_height_of_mountain_blocking + long_name = time integral of height of mountain blocking drag + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zlwb] + standard_name = time_integral_of_height_of_low_level_wave_breaking + long_name = time integral of height of drag due to low level wave breaking + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zogw] + standard_name = time_integral_of_height_of_launch_level_of_orographic_gravity_wave + long_name = time integral of height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_tofd] + standard_name = time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = time integral of momentum flux due to TOFD + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_mtb] + standard_name = time_integral_of_momentum_flux_due_to_mountain_blocking_drag + long_name = time integral of momentum flux due to mountain blocking drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ogw] + standard_name = time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = time integral of momentum flux due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ngw] + standard_name = time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave + long_name = time integral of momentum flux due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ngw] + standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in x wind due to NGW + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt_ngw] + standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in y wind due to NGW + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_finalize + type = scheme