diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 new file mode 100644 index 000000000..94a74b75a --- /dev/null +++ b/physics/GFS_GWD_generic.F90 @@ -0,0 +1,140 @@ +!> \file GFS_GWD_generic.f +!! This file contains the CCPP-compliant orographic gravity wave +!! drag pre interstitial codes. + +module GFS_GWD_generic_pre + +contains + +!> \section arg_table_GFS_GWD_generic_pre_init Argument Table +!! + subroutine GFS_GWD_generic_pre_init() + end subroutine GFS_GWD_generic_pre_init + +!! \section arg_table_GFS_GWD_generic_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | +!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | +!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | +!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for 3d diagnostic fields | flag | 0 | logical | | in | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | in | F | +!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | +!! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine GFS_GWD_generic_pre_run( & + & im, levs, nmtvr, mntvar, & + & hprime, oc, oa4, clx, theta, & + & sigma, gamma, elvmax, lssav, ldiag3d, & + & dtdt, dt3dt, dtf, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, nmtvr + real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) + + real(kind=kind_phys), intent(out) :: & + & hprime(im), oc(im), oa4(im,4), clx(im,4), & + & theta(im), sigma(im), gamma(im), elvmax(im) + + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in) :: dtdt(im,levs) + ! dt3dt only allocated only if ldiag3d is .true. + real(kind=kind_phys), intent(inout) :: dt3dt(:,:) + real(kind=kind_phys), intent(in) :: dtf + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (nmtvr == 14) then ! current operational - as of 2014 + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) + elseif (nmtvr == 10) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + elseif (nmtvr == 6) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + hprime = 0 + oc = 0 + oa4 = 0 + clx = 0 + theta = 0 + gamma = 0 + sigma = 0 + elvmax = 0 + endif ! end if_nmtvr + + if (lssav) then + if (ldiag3d) then + do k=1,levs + do i=1,im + dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf + enddo + enddo + endif + endif + + end subroutine GFS_GWD_generic_pre_run +!> @} + +! \ingroup GFS_ogwd +! \brief Brief description of the subroutine +! +!> \section arg_table_GFS_GWD_generic_pre_finalize Argument Table +!! + subroutine GFS_GWD_generic_pre_finalize() + end subroutine GFS_GWD_generic_pre_finalize + +end module GFS_GWD_generic_pre diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index f8ad355d8..8d3074988 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -165,8 +165,8 @@ end subroutine GFS_MP_generic_post_init !! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | inout | F | !! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | !! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | -!! | raincprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | -!! | rainncprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | +!! | raincprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | +!! | rainncprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | !! | iceprv | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | snowprv | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | graupelprv | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | inout | F | diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f new file mode 100644 index 000000000..4170a3d79 --- /dev/null +++ b/physics/cires_orowam2017.f @@ -0,0 +1,339 @@ + subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, + & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, + & del, sigma, hprime, gamma, theta, + & sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys + use ugwp_common , only : grav, omega2 +! + implicit none + + integer :: im, levs + integer :: npt + integer :: kdt, me, master + integer :: kref(im), ipt(im) + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, + & hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: + & u1, v1, t1, bn2, rho, prsl, del + + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi +! +! out : taup, taud, pkdis +! + real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup + real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud + real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis + real(kind=kind_phys) :: belps, aelps, nhills, selps +! +! multiwave oro-spectra +! locals +! + integer :: i, j, k, isp, iw + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real :: akx(nworo), cxoro(nworo), akx2(nworo) + real :: aspkx(nworo), c2f2(nworo) , cdf2(nworo) + real :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real :: tau_kx(nworo),taub_kx(nworo) + real, dimension(nworo, levs+1) :: wrms, akzw + + real :: tauz(levs+1), rms_wind(levs+1) + real :: wave_act(nworo,levs+1) + + real :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real :: rayf, kturb + real :: uz, bv, bv2,kxsp, fcor2, cf2 + + real :: fdis + real :: wfdm, wfdt, wfim, wfit + real :: betadis, betam, betat, kds, cx, rhofac + real :: etwk, etws, tauk, cx2sat + real :: cdf1, tau_norm +! +! mean flow +! + real, dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + + integer :: nw, nzi, ksrc + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then +771 format( 'vay-oro19 ', 3(2x,F8.3)) + write(6,771) + & maxval(tau_kx)*maxval(taub)*1.e3, + & minval(tau_kx), maxval(tau_kx) + endif +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), + & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, + & xn(i), yn(i)) + + fcor2 = (omega2*sinlat(j))*(omega2*sinlat(j))*fc_flag + + k = ksrc + + bv2 = bn2(i,k) + uz = uzi(k) !u1(j,ksrc)*xn(i)+v1(j,ksrc)*yn(i)! + kturb = ktur(k) + rayf = kalp(k) + rhoint = rhoi(k) + dzmet = dzi(k) + kzw = max(sqrt(bv2)/max(cxmin, uz), mkzmin) +! +! specify oro-kx spectra and related variables k=ksrc +! + do iw = 1, nw + kxw = akx(iw) + cxoro(iw) = 0.0 - uz + c2f2(iw) = fcor2/akx2(iw) + wrms(iw,k)= taub_kx(iw)/rhoint*kzw/kxw + tau_sp(iw, k) = taub_kx(iw) +! +! + if (cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0. ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) then + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off + else + kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) + kzw = sqrt(kzw2) + akzw(iw,k)= kzw + wrms(iw,k)= taub_kx(iw)/rhoint * kzw/kxw + endif + endif + enddo ! nw-spectral loop +! +! defined abobe, k = ksrc: akx(nworo), cxoro(nworo), tau_sp(ksrc, nworo) +! propagate upward multiwave-spectra are filtered by dissipation & instability +! +! tau_sp(:,ksrc+1:levs+1) = tau_sp(:, ksrc) + do k= ksrc+1, levs + uz = uzi(k) + bv2 =bn2(i,k) + bv = sqrt(bv2) + rayf = kalp(k) + rhoint= rhoi(k) + dzmet = dzi(k) + rhofac = rhoi(k-1)/rhoi(k) + + do iw = 1, nworo +! + if (wave_act(iw, k-1) <= 0.0) cycle + cxoro(iw)= 0.0 - uz + if ( cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0.0 ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) wave_act(iw,k:levs+1) = 0.0 + endif + if ( wave_act(iw,k) <= 0.0) cycle +! +! upward propagation +! + kzw2 = Bv2/Cdf2(iw) - akx2(iw) + + if (kzw2 < mkz2min) then + wave_act(iw,k:levs+1) = 0.0 + else +! +! upward propagation w/o reflection +! + kxw = akx(iw) + kzw = sqrt(kzw2) + akzw(iw,k) = kzw + kzw3 = kzw2*kzw + + cx = cxoro(iw) + betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + kds = wkdis(iw,k-1) + + etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) + + kturb = ktur(k)+pkdis(j,k-1) + wfiM = kturb*kzw2 +rayf + wfiT = wfiM ! do updates with Pr-numbers Kv/Kt + cdf1 = sqrt(Cdf2(iw)) + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cdf1)*BetaT + kzi = 2.*kzw*(wfdM+wfdT)*dzmet + Fdis = exp(-kzi) + + etwk = etws*Fdis + Cx2sat = Linsat2*Cdf2(iw) + + if (etwk > cx2sat) then + Kds = kxw*Cdf1*rhp2/kzw3 + etwk = cx2sat + wfiM = kds*kzw2 + wfdM = wfiM/(kxw*Cdf1) + kzi = 2.*kzw*(wfdm + wfdm)*dzmet + etwk = cx2sat*exp(-kzi) + endif +! if( lat(j) eq 40.5 ) then stop + wkdis(iw,k) = kds + wrms(iw,k) = etwk + tauk = etwk*kxw/kzw + tau_sp(iw,k) = tauk *rhoint + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) + & tau_sp(iw,k) = tau_sp(iw,k-1) + + ENDIF ! upward + ENDDO ! spectral + +!......... do spectral sum of rms, wkdis, tau + + tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) + rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau + + if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax + + ENDDO ! k=ksrc+1, levs + + k = ksrc + tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) + tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) + rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) + tauz(levs+1) = tauz(levs) + taup(i, 1:levs+1) = tauz(1:levs+1) + do k=ksrc, levs + taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +!23456 + end subroutine oro_wam_2017 +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + + use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min + implicit none + + integer :: nz, nzi + real, dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real, dimension(nz ) :: bn2 ! define at the interfaces + real, dimension(nz+1) :: pint + real :: xn, yn +! output + + real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real :: zgrow, zmet, rdpm, ritur, kmol, w1 +! paremeters + real, parameter :: hps = 7000., rpspa = 1.e-5 + real, parameter :: rhps=1.0/hps + real, parameter :: h4= 0.25/hps + real, parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real, parameter :: lturb = 30. , uturb = 150.0 + real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + kalp(1:nzi) = 2.e-7 ! radiative damping + + do k=2, nz + rdpm = grav/(pmid(k-1)-pmid(k)) + ui = .5*(u1(k-1)+u1(k)) + vi = .5*(v1(k-1)+v1(k)) + uzi(k) = Ui*xn + Vi*yn + ti = .5*(t1(k-1)+t1(k)) + rhoi(k) = rdi*pint(k)/ti + rdz = rdpm *rhoi(k) + dzi(k) = 1./rdz + uz = u1(k)-u1(k-1) + vz = v1(k)-v1(k-1) + shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) + zmet = -hps*alog(pint(k)*rpspa) + zgrow = exp(zmet*h4) + kmol = 2.e-5*exp(zmet*rhps)+kedmin + ritur = max(bn2(k)/shr2, rimin) + kamp = sqrt(shr2)*lsc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k) = kamp * w1 * w1 +kmol + enddo + + k = 1 + uzi(k) = uzi(k+1) + ktur(k) = ktur(k+1) + rhoi(k) = rdi*pint(k)/t1(k+1) + dzi(k) = rgrav*delp(k)/rhoi(k) + + k = nzi + uzi(k) = uzi(k-1) + ktur(k) = ktur(k-1) + rhoi(k) = rhoi(k-1)*.5 + dzi(k) = dzi(k-1) + + end subroutine oro_meanflow diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 new file mode 100644 index 000000000..226a83f02 --- /dev/null +++ b/physics/cires_ugwp.F90 @@ -0,0 +1,357 @@ +!> \file cires_ugwp.F90 +!! This file contains the Unified Gravity Wave Physics (UGWP) scheme by Valery Yudin (University of Colorado, CIRES) +!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. +!! Unified Formalism: +!! 1. GW Sources: Stochastic and physics based mechanisms for GW-excitations in the lower atmosphere, calibrated by the high-res analyses/forecasts, and observations (3 types of GW sources: orography, convection, fronts/jets). +!! 2. GW Propagation: Unified solver for “propagation, dissipation and breaking” excited from all type of GW sources. +!! 3. GW Effects: Unified representation of GW impacts on the ‘resolved’ flow for all sources (energy-balanced schemes for momentum, heat and mixing). +!! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf + +module cires_ugwp + + use machine, only: kind_phys + + use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + + implicit none + + private + + public cires_ugwp_init, cires_ugwp_run, cires_ugwp_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the CIRES UGWP +#if 0 +!> \section arg_table_cires_ugwp_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |------------------|-------------------------------------------------------------------------------|---------------------------------------------------------|--------|------|-----------|-----------|--------|----------| +!! | me | mpi_rank | MPI rank of current process | index | 0 | integer | | in | F | +!! | master | mpi_root | MPI rank of master process | index | 0 | integer | | in | F | +!! | nlunit | iounit_namelist | fortran unit number for opening namelist file | none | 0 | integer | | in | F | +!! | logunit | iounit_log | fortran unit number for writing logfile | none | 0 | integer | | in | F | +!! | fn_nml2 | namelist_filename | namelist filename for ugwp | none | 0 | character | len=* | in | F | +!! | lonr | number_of_equatorial_longitude_points | number of global points in x-dir (i) along the equator | count | 0 | integer | | in | F | +!! | latr | number_of_latitude_points | number of global points in y-dir (j) along the meridian | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | ak | a_parameter_of_the_hybrid_coordinate | a parameter for sigma pressure level calculations | Pa | 1 | real | kind_phys | in | F | +!! | bk | b_parameter_of_the_hybrid_coordinate | b parameter for sigma pressure level calculations | none | 1 | real | kind_phys | in | F | +!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | +!! | cdmvgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplication factors for cdmb and gwd | none | 1 | real | kind_phys | in | F | +!! | cgwf | multiplication_factors_for_convective_gravity_wave_drag | multiplication factor for convective GWD | none | 1 | real | kind_phys | in | F | +!! | pa_rf_in | pressure_cutoff_for_rayleigh_damping | pressure level from which Rayleigh Damping is applied | Pa | 0 | real | kind_phys | in | F | +!! | tau_rf_in | time_scale_for_rayleigh_damping | time scale for Rayleigh damping in days | d | 0 | real | kind_phys | in | F | +!! | con_p0 | standard_atmospheric_pressure | standard atmospheric pressure | Pa | 0 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif +! ----------------------------------------------------------------------- +! + subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & + lonr, latr, levs, ak, bk, dtp, cdmvgwd, cgwf, & + pa_rf_in, tau_rf_in, con_p0, errmsg, errflg) + +!---- initialization of cires_ugwp + 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 + real(kind=kind_phys), intent (in) :: ak(:), bk(:) + real(kind=kind_phys), intent (in) :: dtp + real(kind=kind_phys), intent (in) :: cdmvgwd(2), 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 + + 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 + + if (is_initialized) return + + call cires_ugwp_mod_init (me, master, nlunit, logunit, fn_nml2, & + lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmvgwd, cgwf, pa_rf_in, tau_rf_in) + + if (.not.knob_ugwp_version==0) then + write(errmsg,'(*(a))') 'Logic error: CCPP only supports version zero of UGWP' + errflg = 1 + return + end if + + is_initialized = .true. + + end subroutine cires_ugwp_init + + +! ----------------------------------------------------------------------- +! finalize of cires_ugwp (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP +#if 0 +!> \section arg_table_cires_ugwp_finalize Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |------------------|-------------------------------------------------------------------------------|---------------------------------------------------------|--------|------|-----------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif + subroutine cires_ugwp_finalize(errmsg, errflg) + + implicit none +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call cires_ugwp_mod_finalize() + + is_initialized = .false. + + end subroutine cires_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 The subroutine executes the CIRES UGWP +#if 0 +!> \section arg_table_cires_ugwp_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |------------------|--------------------------------------------------------------------------------|--------------------------------------------------------------|-----------|------|-----------|-----------|--------|----------| +!! | do_ugwp | do_ugwp | flag to activate CIRES UGWP | flag | 0 | logical | | in | F | +!! | me | mpi_rank | MPI rank of current process | index | 0 | integer | | in | F | +!! | master | mpi_root | MPI rank of master process | index | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | +!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | +!! | lonr | number_of_equatorial_longitude_points | number of global points in x-dir (i) along the equator | count | 0 | integer | | in | F | +!! | oro | orography | orography | m | 1 | real | kind_phys | in | F | +!! | oro_uf | orography_unfiltered | unfiltered orography | m | 1 | real | kind_phys | in | F | +!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | +!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of topographic variables in GWD | count | 0 | integer | | in | F | +!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | in | F | +!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | in | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | in | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | in | F | +!! | do_tofd | turb_oro_form_drag_flag | flag for turbulent orographic form drag | flag | 0 | logical | | in | F | +!! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplication factors for cdmb and gwd | none | 1 | real | kind_phys | in | F | +!! | xlat | latitude | grid latitude in radians | radians | 1 | real | kind_phys | in | F | +!! | xlat_d | latitude_degree | latitude in degrees | degree | 1 | real | kind_phys | in | F | +!! | sinlat | sine_of_latitude | sine of the grid latitude | none | 1 | real | kind_phys | in | F | +!! | coslat | cosine_of_latitude | cosine of the grid latitude | none | 1 | real | kind_phys | in | F | +!! | area | cell_area | area of the grid cell | m2 | 1 | real | kind_phys | in | F | +!! | ugrs | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vgrs | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tgrs | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | qgrs | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prslk | dimensionless_exner_function_at_model_layers | dimensionless Exner function at model layer centers | none | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | del | air_pressure_difference_between_midlayers | air pressure difference between midlayers | Pa | 2 | real | kind_phys | in | F | +!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | vertical index at top atmospheric boundary layer | index | 1 | integer | | in | F | +!! | dusfcg | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | dvsfcg | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag| Pa | 1 | real | kind_phys | out | F | +!! | gw_dudt | tendency_of_x_wind_due_to_ugwp | zonal wind tendency due to UGWP | m s-2 | 2 | real | kind_phys | out | F | +!! | gw_dvdt | tendency_of_y_wind_due_to_ugwp | meridional wind tendency due to UGWP | m s-2 | 2 | real | kind_phys | out | F | +!! | gw_dtdt | tendency_of_air_temperature_due_to_ugwp | air temperature tendency due to UGWP | K s-1 | 2 | real | kind_phys | out | F | +!! | gw_kdis | eddy_mixing_due_to_ugwp | eddy mixing due to UGWP | m2 s-1 | 2 | real | kind_phys | out | F | +!! | tau_tofd | instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag | momentum flux or stress due to TOFD | Pa | 1 | real | kind_phys | out | F | +!! | tau_mtb | instantaneous_momentum_flux_due_to_mountain_blocking_drag | momentum flux or stress due to mountain blocking drag | Pa | 1 | real | kind_phys | out | F | +!! | tau_ogw | instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag | momentum flux or stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | tau_ngw | instantaneous_momentum_flux_due_to_nonstationary_gravity_wave | momentum flux or stress due to nonstationary gravity waves | Pa | 1 | real | kind_phys | out | F | +!! | zmtb | height_of_mountain_blocking | height of mountain blocking drag | m | 1 | real | kind_phys | out | F | +!! | zlwb | height_of_low_level_wave_breaking | height of low level wave breaking | m | 1 | real | kind_phys | out | F | +!! | zogw | height_of_launch_level_of_orographic_gravity_wave | height of launch level of orographic gravity wave | m | 1 | real | kind_phys | out | F | +!! | dudt_mtb | instantaneous_change_in_x_wind_due_to_mountain_blocking_drag | instantaneous change in x wind due to mountain blocking drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dudt_ogw | instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag | instantaneous change in x wind due to orographic gw drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dudt_tms | instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag | instantaneous change in x wind due to TOFD | m s-2 | 2 | real | kind_phys | out | F | +!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | inout | F | +!! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | +!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | con_pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | +!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat !of dry air at constant pressure | J kg-1 K-1| 0 | real | kind_phys | in | F | +!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1| 0 | real | kind_phys | in | F | +!! | con_rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1| 0 | real | kind_phys | in | F | +!! | con_fvirt | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif + +! subroutines original + subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr, & + oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & + do_tofd, cdmbgwd, xlat, xlat_d, sinlat, coslat, area, & + ugrs, vgrs, tgrs, qgrs, 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, dudt, dvdt, dtdt, rdxzb, & + con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr + integer, intent(in), dimension(im) :: kpbl + real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma, 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, ntrac):: qgrs + real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(2) + logical, intent(in) :: do_ugwp, do_tofd + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + + real(kind=kind_phys), intent(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 + + 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. + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality + if (do_ugwp) then + + ! 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 + + zlwb(:) = 0. + + call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & + dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & + dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd, & + me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) + + + ! 1) non-stationary GW-scheme with GMAO/MERRA GW-forcing + call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + + + ! 2) non-stationary GW-scheme with GEOS-5/MERRA GW-forcing + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & + prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_ngw, me, master, kdt) + + if(pogw /= 0.)then + + 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 + + tau_mtb = 0. ; tau_ogw =0.; tau_tofd =0. + dudt_mtb =0. ; dudt_ogw = 0.; dudt_tms=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.; ed_dvdt(:,:) = 0. ; ed_dtdt(:,:) = 0. + + call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, qgrs(:,:,1), & + del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) + gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked + gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked + gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked + + + + endif ! do_ugwp + + end subroutine cires_ugwp_run + + +end module cires_ugwp diff --git a/physics/cires_ugwp_initialize.F90 b/physics/cires_ugwp_initialize.F90 new file mode 100644 index 000000000..6177100b7 --- /dev/null +++ b/physics/cires_ugwp_initialize.F90 @@ -0,0 +1,710 @@ +!=============================== +! 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 oro_state + +! integer, parameter :: kind_phys=8 +! integer, parameter :: nvaroro=14 +! real (kind=kind_phys), allocatable :: oro_stat(:, :) +! contains + +! subroutine fill_oro_stat(nx, oc, oa4, clx4, theta, gamm, sigma, elvmax, hprime) + +! real (kind=kind_phys),dimension(nx) :: oc, theta, gamm, sigma, elvmax, hprime +! real(kind=kind_phys),dimension(nx,4) :: oa4, clx4 +! integer :: i +! do i=1, nx +! oro_stat(i,1) = hprime(i) +! oro_stat(i,2) = oc(i) +! oro_stat(i,3:6) = oa4(i,1:4) +! oro_stat(i,7:10) = clx4(i,1:4) +! oro_stat(i,11) = theta(i) +! oro_stat(i,12) = gamm(i) +! oro_stat(i,13) = sigma(i) +! oro_stat(i,14) = elvmax(i) +! enddo +! end subroutine fill_oro_stat + +! end module oro_state + + module ugwp_common +! + implicit none + + real, parameter :: grav =9.80665, cpd = 1004.6, grcp = grav/cpd + real, parameter :: rd = 287.05 , rv =461.5 + real, parameter :: rgrav = 1.0/grav + + real, parameter :: fv = rv/rd - 1.0 + real, parameter :: rdi = 1.0 / rd + real, parameter :: gor = grav/rd + real, parameter :: gr2 = grav*gor + real, parameter :: gocp = grav/cpd + real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi +! + real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 + + real, parameter :: arad = 6370.e3 + real, parameter :: rcpd2 = 0.5/cpd, rcpd = 1./cpd + real, parameter :: dw2min=1.0 + real, parameter :: bnv2min=1.e-6 + real, parameter :: velmin=sqrt(dw2min) + real, parameter :: omega1 = pi2/86400. + real, parameter :: omega2 = 2.*omega1 + end module ugwp_common +! +! +!=================================================== +! +!Part-1 init => wave dissipation + RFriction +! +!=================================================== + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) + implicit none + + integer :: levs + real, intent(in) :: zkm(levs), pmb(levs) + 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. +! + real, parameter :: kdrag = 1./86400./10. + real, parameter :: zdrag = 100. + real, parameter :: zgrow = 50. +! + real :: vumol, mumol, keddy, ion_drag +! + do k=1, levs + vumol = vusurf*exp(-zkm(k)/hpmol) + mumol = musurf*exp(-zkm(k)/hpmol) + + keddy = kturbo*exp(-((zkm(k)-zturbo) /zturw)**2) + + kvg(k) = vumol + keddy + ktg(k) = mumol + keddy*inv_pra + + krad(k) = alpha +! + ion_drag = kdrag +! + kion(k) = ion_drag + enddo + + k= levs+1 + kion(k) = kion(k-1) + krad(k) = krad(k-1) + kvg(k) = kvg(k-1) + ktg(k) = ktg(k-1) +! + end subroutine init_global_gwdis +! +! + subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + implicit none + + integer :: levs + real :: pa_rf, tau_rf + real :: dtp + + real :: pmb(levs) + real :: rfdis(levs), rfdist(levs) + integer :: levs_rf + + real :: krf, krfz + integer :: k +! + rfdis(1:levs) = 1.0 + rfdist(1:levs) = 0.0 + levs_rf = levs + if (tau_rf <= 0.0 .or. pa_rf == 0.0) return + + krf = 1.0/(tau_rf*86400.0) + + do k=levs, 1, -1 + if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" + krfz = krf*log(pa_rf/pmb(k)) + rfdis(k) = 1.0/(1.+krfz*dtp) + rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp + levs_rf = k + endif + enddo + + end subroutine rf_damp_init +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init +! +!========================================================================= + module ugwp_oro_init + + use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + + 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' +! + 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 :: hpmax=2400.0, hpmin=25.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 +! + real, parameter :: hncrit=9000. ! max value in meters for elvmax + +! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt + + real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor + real, parameter :: hminmt=50. ! min mtn height (*j*) + real, parameter :: minwnd=1.0 ! min wind component (*j*) + real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + + 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 :: lzmax = 18.e3 ! 18 km + real, parameter :: mkzmin = 6.28/lzmax + real, parameter :: mkz2min = mkzmin*mkzmin + real, parameter :: zbr_pi = 3./2.*4.*atan(1.0) ! 3pi/2 + real, parameter :: zbr_ifs = 2.*atan(1.0) ! pi/2 + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw, cdmbgwd ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) + ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 + real :: cdmbX + real :: kxw + real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now +!-----------------------------! GFS-setup for cdmb & cleff +! cdmb = 4.0 * (192.0/IMX) +! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) +! + real, parameter :: lonr_refmb = 4.0 * 192.0 + real, parameter :: lonr_refgw = 192.0 + +! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + cdmb = cdmbX + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + + cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac + +!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac + + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +! +!.................................................................... +! higher res => smaller h' ..&.. higher kx +! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) +!.................................................................... +! +! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) + end subroutine init_oro_gws +! + + end module ugwp_oro_init +! ========================================================================= +! +! ugwp_conv_init +! +!========================================================================= + module ugwp_conv_init + + implicit none + real :: eff_con ! scale factors for conv GWs + integer :: nwcon ! number of waves + integer :: nazcon ! number of azimuths + integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud + real :: con_dlength + real :: con_cldf + + real, parameter :: cmin = 5 !2.5 + real, parameter :: cmax = 95. !82.5 + real, parameter :: cmid = 22.5 + real, parameter :: cwid = cmid + real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real, parameter :: mstar = 6.28e-3/2. ! 2km + real :: dc + + real, allocatable :: ch_conv(:), spf_conv(:) + real, allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw, cgwf) + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: cgwf(2) + real :: kxw, effac + real :: work1 = 0.5 + real :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = pi2*arad/float(lonr) + con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) +! +! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" +! + if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) + if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) + if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) + if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) +! +! we may use different spectral "shapes" +! for example FVS-93 "Desabeius" +! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail +! + do k = 1,nwaves + chk = cmin + (k-1)*dc + tn4 = (mstar*chk)**4 + ch_conv(k) = chk + spf_conv(k) = bns4*chk/(bns4+tn4) + enddo + + snorm = sum(spf_conv) + spf_conv = spf_conv/snorm*1.5 + + call init_nazdir(nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init +!========================================================================= +! +! ugwp_fjet_init +! +!========================================================================= + + module ugwp_fjet_init + implicit none + real :: eff_fj ! scale factors for conv GWs + integer :: nwfj ! number of waves + integer :: nazfj ! number of azimuths + integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_fjet(:) , spf_fjet(:) + real, allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: kxw, effac , chk + + integer :: k + + nwfj = nwaves + nazfj = nazdir + nstfj = nstoch + eff_fj = effac + + if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) + if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) + if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) + if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_fjet(k) = chk + spf_fjet(k) = 1.0 + enddo + call init_nazdir(nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init +! +!========================================================================= +! +! + module ugwp_okw_init +!========================================================================= + implicit none + + real :: eff_okw ! scale factors for conv GWs + integer :: nwokw ! number of waves + integer :: nazokw ! number of azimuths + integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_okwp(:), spf_okwp(:) + real, allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + + use ugwp_common, only : pi2, arad + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: kxw, effac , chk + + integer :: k + + nwokw = nwaves + nazokw = nazdir + nstokw = nstoch + eff_okw = effac + + if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) + if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) + if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) + if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_okwp(k) = chk + spf_okwp(k) = 1. + enddo + + call init_nazdir(nazdir, xaz_okwp, yaz_okwp) + + end subroutine init_okw_gws + + end module ugwp_okw_init + +!=============================== end of GW sources +! +! init specific gw-solvers (1,2,3,4) +! + +!=============================== +! Part -3 init wave solvers +!=============================== + + module ugwp_lsatdis_init + implicit none + + integer :: nwav, nazd + integer :: nst + real :: eff + integer, parameter :: incdim = 4, iazdim = 4 +! + contains + + subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + + implicit none +! + integer :: me, master + integer :: nwaves, nazdir + integer :: nstoch + real :: effac + logical :: do_physb + real :: kxw +! +!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces +! are not actibve +! + integer :: inc, jk, jl, iazi, i, j, k + + if( nwaves == 0 .or. nstoch == 1 ) then +! redefine from the default + nwav = incdim + nazd = iazdim + nst = 0 + eff = 1.0 + else +! from input_nml multi-wave spectra + nwav = nwaves + nazd = nazdir + nst = nstoch + eff = effac + endif +! + end subroutine initsolv_lsatdis +! + end module ugwp_lsatdis_init +! +! + module ugwp_wmsdis_init + + implicit none + + real, parameter :: maxdudt = 250.e-5 + + real, parameter :: hpscale= 7000., rhp2 = 0.5/hpscale + real, parameter :: omega2 = 2.*6.28/86400 + real, parameter :: gptwo=2.0 + + real, parameter :: dked_min =0.01 + real, parameter :: gssec = (6.28/30.)**2 ! max-value for bn2 + real, parameter :: bv2min = (6.28/60./120.)**2 ! min-value for bn2 7.6(-7) 2 hrs + real, parameter :: minvel = 0.5 + +! +! make parameter list that will be passed to SOLVER +! + + real, parameter :: v_kxw = 6.28e-3/200. + real, parameter :: v_kxw2 = v_kxw*v_kxw + real, parameter :: tamp_mpa = 30.e-3 + real, parameter :: zfluxglob= 3.75e-3 + + real , parameter :: nslope=1 ! the GW sprctral slope at small-m +! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level +! integer, parameter :: ilaunch=klaunch + + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + real , parameter :: ucrit2=0.5 + + real , parameter :: zcimin = ucrit2 + real , parameter :: zcimax = 125.0 + real , parameter :: zgam = 0.25 + real , parameter :: zms_l = 2000.0 + + integer :: ilaunch + real :: gw_eff + +!=========================================================================== + integer :: nwav, nazd, nst + real :: eff + + real :: zaz_fct , zms + real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real, allocatable :: zcosang(:), zsinang(:) + 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) +! + use ugwp_common, only : pi, pi2 + 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 +! +!locals +! + integer :: inc, jk, jl, iazi +! + real :: zang, zang1, znorm + real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + + 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 + + allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) + allocate ( zcosang(nazd), zsinang(nazd) ) + + if (me == master) then + print *, 'ugwp_v0: init_gw_wmsdis_control ' +! print *, 'ugwp_v0: WMSDIS launch layer ', klaunch + print *, 'ugwp_v0: WMSDIS launch layer ', ilaunch + print *, 'ugwp_v0: WMSDID tot_mflux in mpa', tamp_mpa*1000. + 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 factot for azimuthal sums + +! define coordinate transform for "Ch" ....x = 1/c stretching transform +! ----------------------------------------------- +! note that this is expresed in terms of the intrinsic phase speed +! at launch ci=c-u_o so that the transformation is identical +! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform +! + zxmax = 1.0 / zcimin + zxmin = 1.0 / zcimax + zxran = zxmax - zxmin + zdx = zxran / real(nwav-1) ! dkz +! + zx1 = zxran/(exp(zxran/zgam)-1.0 ) ! zgam =1./4. + zx2 = zxmin - zx1 + +! +! computations for zci =1/zx +! if(lgacalc) zgam=(zxmax-zxmin)/log(zxmax/zxmin) +! zx1=zxran/(exp(zxran/zgam)-1.0_jprb) +! zx2=zxmin-zx1 + zms = 2.*pi/zms_l + do inc=1, nwav + ztx = real(inc-1)*zdx+zxmin + zx = zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 + zci(inc) = 1.0 /zx !eq. 28 of scinocca 2003 + zdci(inc) = zci(inc)**2*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + enddo +! +! +! all done and print-out +! +! + if (me == master) then + print * + print *, 'ugwp_v0: zcimin=' , zcimin + print *, 'ugwp_v0: zcimax=' , zcimax + print *, 'ugwp_v0: cd_crit=', zgam ! m/s precision for crit-level + print *, 'ugwp_v0: launch_level', ilaunch + print *, ' ugwp_v0 zms_l=', zms_l + print *, ' ugwp_vgw nslope=', nslope + + print * + endif + + + end subroutine initsolv_wmsdis +! +! make a list of all-initilized parameters needed for "gw_solver_wmsdis" +! + + end module ugwp_wmsdis_init +!========================================================================= +! +! work TODO for 2-extra WAM-solvers: +! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) +! +!========================================================================= + subroutine init_dspdis + implicit none + end subroutine init_dspdis + + subroutine init_adodis + implicit none + end subroutine init_adodis + diff --git a/physics/cires_ugwp_module.F90 b/physics/cires_ugwp_module.F90 new file mode 100644 index 000000000..7a675c3cc --- /dev/null +++ b/physics/cires_ugwp_module.F90 @@ -0,0 +1,670 @@ +! +module cires_ugwp_module + +! +! driver is called after pbl & before chem-parameterizations +! +!.................................................................................... +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +!................................................................................... +! +! + implicit none + logical :: module_is_initialized +!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction + + logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources + logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver + + real, parameter :: arad=6370.e3 + real, parameter :: pi = atan(1.0) + real, parameter :: pi2 = 2.*pi + real, parameter :: hps = 7000. + real, parameter :: hpskm = hps/1000. +! + real :: kxw = 6.28e-3/100. ! single horizontal wavenumber of ugwp schemes + real, parameter :: ricrit = 0.25 + real, parameter :: frcrit = 0.50 + real, parameter :: linsat = 1.00 + real, parameter :: linsat2 = linsat*linsat +! + + integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) + integer, dimension(4) :: knob_ugwp_source ! [1,1,1,0] - (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_wvspec ! number of waves for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_azdir ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_stoch ! 1 - deterministic ; 0 - stochastic + real, dimension(4) :: knob_ugwp_effac ! efficiency factors for- (oro, fronts, conv, imbf-owp] + + integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag + integer :: knob_ugwp_doheat=1 ! 1 -gwheat + integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing + integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw +! + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + real :: ugwp_effac + +! + data knob_ugwp_source / 1,0, 1, 0 / ! oro-conv-fjet-okw-taub_lat: 1-active 0-off + data knob_ugwp_wvspec /1,32,32,32/ ! number of waves for- (oro, fronts, conv, imbf-owp, taulat] + data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] + data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option + data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] + integer :: knob_ugwp_version = 0 + integer :: launch_level = 55 +! + namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & + knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & + knob_ugwp_ndx4lh, knob_ugwp_version, launch_level + +!&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 +! +! limiters +! + real, parameter :: max_kdis = 400. ! 400 m2/s + real, parameter :: max_axyz = 400.e-5 ! 400 m/s/day + real, parameter :: max_eps = max_kdis*4.e-7 ! ~16 K/day +! +!====================================================================== + 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, rhp2=0.5*rhp1, rhp4 = rhp2*rhp2 + 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 GFS_driver.F90 +! +! ----------------------------------------------------------------------- + subroutine cires_ugwp_mod_init (me, master, nlunit, logunit, fn_nml2, & + lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & + pa_rf_in, tau_rf_in) +! +! input_nml_file ='input.nml'=fn_nml +! + use ugwp_oro_init, only : init_oro_gws + use ugwp_conv_init, only : init_conv_gws + use ugwp_fjet_init, only : init_fjet_gws + use ugwp_okw_init, only : init_okw_gws + use ugwp_wmsdis_init, only : initsolv_wmsdis, ilaunch + use ugwp_lsatdis_init, only : initsolv_lsatdis + 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 + 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 schemes + real, intent (in) :: pa_rf_in, tau_rf_in + + character(len=64), intent (in) :: fn_nml2 + character(len=64), parameter :: fn_nml='input.nml' + +! character, intent (in) :: input_nml_file +! integer, parameter :: logunit = 6 + integer :: ios + logical :: exists + real :: dxsg + integer :: k +! + 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) +! + ilaunch = launch_level + pa_rf = pa_rf_in + tau_rf = tau_rf_in + +! write version number and namelist to log file + if (me == master) then + write (logunit, *) " ================================================================== " + write (logunit, *) "cires_ugwp_cires" + write (logunit, nml = cires_ugwp_nml) + endif +! +! effective kxw - resolution-aware +! + dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh +! +! kxw = pi2/dxsg +! +! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff +! + +! allocate(fcor(latr), fcor2(latr) ) +! + allocate( kvg(levs+1), ktg(levs+1) ) + allocate( krad(levs+1), kion(levs+1) ) + allocate( zkm(levs), pmb(levs) ) + allocate( rfdis(levs), rfdist(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 + zkm(k) = -hpskm*alog(pmb(k)/pref) + enddo +! +! Part-1 :init_global_gwdis +! + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) + call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) +! +! Part-2 :init_SOURCES_gws +! + +! +! call init-solver for "stationary" multi-wave spectra and sub-grid oro +! + call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) +! +! call init-sources for "non-sationary" multi-wave spectra +! + do_physb_gwsrcs=.true. + + IF (do_physb_gwsrcs) THEN + + if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' + if (knob_ugwp_wvspec(4) > 0) then +! okw + call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & + knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) + if (me == master) print *, ' init_okw_gws ' + endif + + if (knob_ugwp_wvspec(3) > 0) then +! fronts + call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & + knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) + if (me == master) print *, ' init_fjet_gws ' + endif + + if (knob_ugwp_wvspec(2) > 0) then +! conv + call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) + if (me == master) & + print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + + endif + + ENDIF !IF (do_physb_gwsrcs) + +!====================== +! 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 + + 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 *, ' VAY-ugwp is initialized ', module_is_initialized + + end subroutine cires_ugwp_mod_init + +! ----------------------------------------------------------------------- +! +! driver of cires_ugwp (_driver) +! called from GFS_physics_driver.F90 +! +! ----------------------------------------------------------------------- +! call cires_ugwp_driver & +! (im, levs, dtp, kdt, me, lprnt, Model%lonr, & +! Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & +! Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & +! Statein, delp_gws, Oro_stat, & +! dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & +! Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & +! Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & +! Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & +! Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & +! Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & +! Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & +! Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & +! Diag%du3dt_ogw, Diag%du3dt_tms ) + + subroutine cires_ugwp_driver & + (im, levs, dtp, kdt, me, lprnt, lonr, & + pa_rf, tau_rf, cdmbgwd, xlat, xlatd, sinlat, coslat, & + ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & + delp, orostat, kpbl, & + dusfc, dvsfc, dudt, dvdt, dtdt, kdis, & + axtot, axo, axc, axf, aytot, ayo, ayc, ayf, & + eps_tot, ekdis, trig_okw, trig_fgf, & + dcheat, precip, cld_klevs, zmtb, scheat, dlength, cldf, & + taus_sso, taus_ogw, tauf_ogw, tauf_ngw, & + ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb, ugw_axlwb, ugw_axtms ) + +! + use machine, only: kind_phys + use physcons, only: con_cp, con_fvirt, con_g, con_rd + use ugwp_common, only: omega2 +! +! + use ugwp_okw_init, only : & + eff_okw, nstokw, nwokw, ch_okwp, nazokw, spf_okwp, xaz_okwp, yaz_okwp + use ugwp_conv_init, only : & + eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv + use ugwp_fjet_init, only : & + eff_fj, nstfj, nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet + +! + implicit none +! + + logical :: lprnt + integer :: me, im, levs, kdt, lonr + real(kind_phys) :: dtp + real(kind_phys) :: pa_rf, tau_rf + real(kind_phys) :: cdmbgwd(2) + + integer, intent(in) :: kpbl(im) + real(kind_phys) :: hpbl(im) + real(kind_phys), intent(in) :: orostat(im, 14) + real(kind_phys), intent(in), dimension(im,levs) :: ugrs, vgrs, & + tgrs, qgrs, prsi, prsl, prslk, phii, phil, delp +! + real(kind_phys), dimension(im) :: xlat, xlatd, sinlat, coslat + real(kind_phys), dimension(im, levs) :: trig_okw, trig_fgf + real(kind_phys), dimension(im) :: precip ! precip-n rates and + integer , dimension(im, 3) :: cld_klevs ! indices fo cloud top/bot/? + real(kind_phys), dimension(im, levs) :: dcheat, scheat ! deep and shal conv heat tend. + + + real(kind_phys), dimension(im) :: dlength ! tail-grid box scale in meters + real(kind_phys), dimension(im) :: cldf ! "bizzard" old cgwd-tuning knobs dimensionless +!=================== +! tendency + kdis +!=================== + real(kind_phys), dimension(im, levs) :: dudt, dvdt, dtdt, kdis + real(kind_phys), dimension(im, levs) :: axtot, axo, axc, axf + real(kind_phys), dimension(im, levs) :: aytot, ayo, ayc, ayf + real(kind_phys), dimension(im, levs) :: eps_tot, ekdis + +! + real(kind_phys), dimension(im, levs) :: eds_o, kdis_o + real(kind_phys), dimension(im, levs) :: eds_c, kdis_c + real(kind_phys), dimension(im, levs) :: eds_f, kdis_f + real(kind_phys), dimension(im, levs) :: ax_rf, ay_rf, eps_rf +! +!================================================================================== +! diagnostics for OGW & NGW + SSO effects axmtb, axlwb, axtms +!================================================================================== + real(kind_phys), dimension(im) :: dusfc, dvsfc + real(kind_phys), dimension(im) :: taus_sso, taus_ogw, tauf_ogw, tauf_ngw + real(kind_phys), dimension(im) :: ugw_zmtb, ugw_zlwb, ugw_zogw + real(kind_phys), dimension(im, levs) :: ugw_axmtb,ugw_axlwb, ugw_axtms + real(kind_phys), dimension(im, levs) :: tauz_ogw, tauz_ngw, wtauz + +! +! knob_ugwp_source=[ 1, 1, 1, 0 ] +! oro conv nst imbal-okw +! locals +! + integer :: i, j, k, istype, ido +! +! internal diagnostics for oro-waves, lee waves, and mtb : +! + real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw + real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb + real(kind_phys), dimension(im) :: zmtb, zlwb, zogw ! GW-launch levels in "meters" +! + real(kind_phys), dimension(im) :: fcor, c2f2 +! +! three sources with different: a) spectra-content/azimuth; b) efficiency ;c) spectral shape +! + real(kind_phys), dimension(im) :: taub_con, taub_fj, taub_okw + integer , dimension(im) :: klev_okw, klev_fj, klev_con + integer , dimension(im) :: if_okw, if_con, if_fj + integer :: nf_okw, nf_con, nf_fj +! + dudt = 0. + dvdt = 0. + dtdt = 0. + kdis = 0. + axo = 0. ; axc = 0. ; axf = 0. + ayo = 0. ; ayc = 0. ; ayf = 0. + eds_o = 0. ; kdis_o = 0. ; eds_f = 0. ; kdis_f = 0. ; eds_c = 0. ; kdis_c = 0. + ax_rf = 0. ; ay_rf = 0. ; eps_rf = 0 + + hpbl(:) = 2000. ! hpbl (1:im) = phil(1:im, kpbl(1:im)) +! + + do i=1, im + fcor(i) = omega2*sinlat(i) + c2f2(i) = fcor(i)*fcor(i)/(kxw*kxw) + enddo + +! i=im +! print *, i, fcor(i), 6.28e-3/kxw, sqrt(c2f2(i)) +! print *, maxval(statein%prsl/statein%tgrs)/287. , ' density ' + +! +! +! What can be computed for ALL types of GWs? => +! "Br-Vi frequency"with "limits" in case of "conv-unstable" layers +! Background dissipation: Molecular + Eddy +! Wind projections may differ from GW-sources/propagation azimuths +! + do istype=1, size(knob_ugwp_source) + + ido = knob_ugwp_source(istype) ! 0 or 1 off or active + + ugwp_azdir = knob_ugwp_azdir(istype) + ugwp_stoch = knob_ugwp_stoch(istype) + ugwp_nws = knob_ugwp_wvspec(istype) + ugwp_effac = knob_ugwp_effac(istype) + +! +! oro-gw effects +! + if (ido == 1 .and. istype ==1 ) then +! +! 1. solve for OGW effects on the mean flow +! 2. all parts of ORO effexra inside: MTB TOFD LeeWB OGW-drag +! + call ugwp_oro(im, levs, dtp, kdt, me, lprnt, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + orostat, hpbl, axo, ayo, eds_o, kdis_o, & + dusfc, dvsfc, dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, & + dusfc_lwb, dvsfc_lwb, zmtb, zlwb, zogw,tauf_ogw,tauz_ogw,& + ugw_axmtb,ugw_axlwb, ugw_axtms) +! +! taus_sso, taus_ogw, tauz_ogw, tauz_ngw, tauf_ogw, tauf_ngw, & +! ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb,ugw_axlwb, ugw_axtms +! collect column-integrated "dusfc, dvsfc" only for oro-waves +! + taus_sso = dusfc_mb + dusfc_lwb + dusfc_ogw + taus_ogw = dusfc_ogw + ugw_zmtb = zmtb + ugw_zlwb = zlwb + ugw_zogw = zogw + +! tauz_ogw/tauf_ogw => output +! ugwp_azdir, ugwp_stoch, ugwp_nws ..... "multi-wave + stochastic" +! +! stationary gw-mode ch=0, with "gw_solver_linsat" +! compute column-integrated "dusfc, dvsfc" only for oro-waves +! + dudt = dudt + axo * ugwp_effac + dvdt = dvdt + ayo * ugwp_effac + dtdt = dtdt + eds_o * ugwp_effac + kdis = kdis + kdis_o* ugwp_effac +! print *, ' ido istype ORO=1 ', ido, istype, ' ugwp_oro as a solver ' + endif + + if (ido == 1 .and. istype ==2 ) then +! +! convective gw effects +! +! 1. specify spectra + forcing nstcon, nwcon, ch_conv, nazcon, spf_conv +! + call get_spectra_tau_convgw & + (nwcon, im, levs, dcheat, scheat, precip, cld_klevs, & + xlatd, sinlat, coslat, taub_con, klev_con, if_con, nf_con) +! +! 2. solve for GW effects on the mean flow +! + if ( nf_con > 0) then + + klev_con(:) = 52 ! ~5 km +! +!eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv +! + if (knob_ugwp_solver == 1) call gw_solver_linsatdis & + (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & + nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv, & + fcor, c2f2, ugrs, vgrs, tgrs, qgrs, prsi, delp, & + prsl, prslk, phii, phil, & + axc, ayc, eds_c, kdis_c, wtauz) + + + if (knob_ugwp_solver == 2) then +! print *, ' before CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver + call gw_solver_wmsdis & + (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & + nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + axc, ayc, eds_c, kdis_c, wtauz) +! print *, ' after ido istype CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver + endif + + dudt = dudt + axc * ugwp_effac + dvdt = dvdt + ayc * ugwp_effac + dtdt = dtdt + eds_c * ugwp_effac + kdis = kdis + kdis_c * ugwp_effac + + tauz_ngw = wtauz + + endif + + endif + + if (ido == 1 .and. istype ==3 ) then +! +! nonstationary gw effects +! +! 1. specify spectra + forcing +! + call get_spectra_tau_nstgw (nwfj, im, levs, & + trig_fgf, xlatd, sinlat, coslat, taub_fj, klev_fj, if_fj, nf_fj) +! +! 2. solve for GW effects on the mean flow +! + print *, ' tau_nstgw nf_fj-GW triggers ', nf_fj, ' ugwp_solver = ', knob_ugwp_solver + if ( nf_fj > 0) then + + if (knob_ugwp_solver == 1) call gw_solver_linsatdis & + (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & + nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + axf, ayf, eds_f, kdis_f, wtauz) + + + + if (knob_ugwp_solver == 2) call gw_solver_wmsdis & + (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & + nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + axf, ayf, eds_f, kdis_f, wtauz) + + dudt = dudt + axf * ugwp_effac + dvdt = dvdt + ayf * ugwp_effac + dtdt = dtdt + eds_f * ugwp_effac + kdis = kdis + kdis_f * ugwp_effac + tauz_ngw = wtauz + print *, ' ido istype for FJ 1-4 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver + + endif + endif +! print *, ' ido istype for okw 1-4 ', ido, istype + if (ido == 1 .and. istype == 4 ) then +! +! nonstationary gw effects due to both "convection +fronts/jets " = imbalance of rs-flow +! +! 1. specify spectra + forcing +! + call get_spectra_tau_okw (nwokw, im, levs,& + trig_okw, xlatd, sinlat, coslat, taub_okw, klev_okw, if_okw, nf_okw) +! +! 2. solve for GW effects on the mean flow +! + if ( nf_okw > 0) then +! + if (knob_ugwp_solver == 1) call gw_solver_linsatdis & + (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & + nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + axf, ayf, eds_f, kdis_f, wtauz) + + + if (knob_ugwp_solver == 2) call gw_solver_wmsdis & + (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & + nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & + fcor, c2f2, ugrs, vgrs, tgrs, & + qgrs, prsi, delp, prsl, prslk, phii, phil, & + axf, ayf, eds_f, kdis_f, wtauz) + + dudt = dudt + axf * ugwp_effac + dvdt = dvdt + ayf * ugwp_effac + dtdt = dtdt + eds_f * ugwp_effac + kdis = kdis + kdis_f * ugwp_effac + tauz_ngw = wtauz + endif + endif +! +! broad gw-spectra +! + 356 continue + enddo +! +! gw-diag only +! + axtot = dudt + aytot = dvdt + eps_tot = dtdt + +! +! optional rf-damping +! + if (do_rfdamp) then +! +! + call rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, ugrs, vgrs, ax_rf, ay_rf, eps_rf) +! +! gw-diag only + rf-damping ..... now orchestrate it with FV3-dycore RF-damping +! + do k=levs_rf, levs + + dudt(:,k) = dudt(:,k) + ax_rf(:,k) + dvdt(:,k) = dvdt(:,k) + ay_rf(:,k) + dtdt(:,k) = dtdt(:,k) + eps_rf(:,k) + + enddo + + endif +!================================================================================ +! To update U-V-T STATE by [dudt dvdt dtdt kdis+rf] => Solve 3-diag VD-equation +!================================================================================ +! to do for fv3wam=> +! joint eddy+molecular viscosity/conductivity/diffusion +! requires "dqdt" + dudt_vis, dvdt_vis. dtdt_cond + +! print *, ' cires_ugwp_driver +++++++++++++++++ ' +! + end subroutine cires_ugwp_driver + + +!============================================= + + + subroutine cires_ugwp_advance +!----------------------------------------------------------------------- +! +! options for the day-to-day variable sources/spectra + diagnostics +! for stochastic "triggers" +! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields +! or use for stochastic GWP-sources "memory" +!----------------------------------------------------------------------- + implicit none +! +! update sources +! a) physics-based triggers for multi-wave +! b) stochastic-based spectra and amplitudes +! c) use "memory" on GW-spectra from previous time-step +! d) update "background" GW dissipation as needed +! + end subroutine cires_ugwp_advance + +! +! ----------------------------------------------------------------------- +! finalize of cires_ugwp (_finalize) +! ----------------------------------------------------------------------- + + + subroutine cires_ugwp_mod_finalize +! +! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" +! before "end" of the FV3GFS +! + implicit none +! +! deallocate arrays employed in: +! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! + deallocate( kvg, ktg ) + deallocate( krad, kion ) + deallocate( zkm, pmb ) + deallocate( rfdis, rfdist) + + end subroutine cires_ugwp_mod_finalize +! + end module cires_ugwp_module + diff --git a/physics/cires_ugwp_post.F90 b/physics/cires_ugwp_post.F90 new file mode 100755 index 000000000..8393dd8d2 --- /dev/null +++ b/physics/cires_ugwp_post.F90 @@ -0,0 +1,115 @@ +!> \file cires_ugwp_post.F90 +!! This file contains +module cires_ugwp_post + +contains + +!>\defgroup cires_ugwp_post CIRES UGWP Scheme Post +!! @{ +!> \section arg_table_cires_ugwp_post_init Argument Table +!! + subroutine cires_ugwp_post_init () + end subroutine cires_ugwp_post_init + +!>@brief The subroutine initializes the CIRES UGWP +#if 0 +!> \section arg_table_cires_ugwp_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |------------------|--------------------------------------------------------------------------------|------------------------------------------------------------------------|-----------|------|-----------|-----------|--------|----------| +!! | ldiag_ugwp | diag_ugwp_flag | flag for CIRES UGWP Diagnostics | flag | 0 | logical | | in | F | +!! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | gw_dudt | tendency_of_x_wind_due_to_ugwp | zonal wind tendency due to UGWP | m s-2 | 2 | real | kind_phys | in | F | +!! | tau_tofd | instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag | momentum flux or stress due to TOFD | Pa | 1 | real | kind_phys | in | F | +!! | tau_mtb | instantaneous_momentum_flux_due_to_mountain_blocking_drag | momentum flux or stress due to mountain blocking drag | Pa | 1 | real | kind_phys | in | F | +!! | tau_ogw | instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag | momentum flux or stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | +!! | tau_ngw | instantaneous_momentum_flux_due_to_nonstationary_gravity_wave | momentum flux or stress due to nonstationary gravity waves | Pa | 1 | real | kind_phys | in | F | +!! | zmtb | height_of_mountain_blocking | height of mountain blocking drag | m | 1 | real | kind_phys | in | F | +!! | zlwb | height_of_low_level_wave_breaking | height of low level wave breaking | m | 1 | real | kind_phys | in | F | +!! | zogw | height_of_launch_level_of_orographic_gravity_wave | height of launch level of orographic gravity wave | m | 1 | real | kind_phys | in | F | +!! | dudt_mtb | instantaneous_change_in_x_wind_due_to_mountain_blocking_drag | instantaneous change in x wind due to mountain blocking drag | m s-2 | 2 | real | kind_phys | in | F | +!! | dudt_ogw | instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag | instantaneous change in x wind due to orographic gw drag | m s-2 | 2 | real | kind_phys | in | F | +!! | dudt_tms | instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag | instantaneous change in x wind due to TOFD | m s-2 | 2 | real | kind_phys | in | F | +!! | cnvgwd | flag_convective_gravity_wave_drag | flag for conv gravity wave drag | flag | 0 | logical | | inout | F | +!! | tot_zmtb | time_integral_of_height_of_mountain_blocking | time integral of height of mountain blocking drag | m | 1 | real | kind_phys | inout | F | +!! | tot_zlwb | time_integral_of_height_of_low_level_wave_breaking | time integral of height of drag due to low level wave breaking | m | 1 | real | kind_phys | inout | F | +!! | tot_zogw | time_integral_of_height_of_launch_level_of_orographic_gravity_wave | time integral of height of launch level of orographic gravity wave | m | 1 | real | kind_phys | inout | F | +!! | tot_tofd | time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag | time integral of momentum flux due to TOFD | Pa | 1 | real | kind_phys | inout | F | +!! | tot_mtb | time_integral_of_momentum_flux_due_to_mountain_blocking_drag | time integral of momentum flux due to mountain blocking drag | Pa | 1 | real | kind_phys | inout | F | +!! | tot_ogw | time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag | time integral of momentum flux due to orographic gravity wave drag | Pa | 1 | real | kind_phys | inout | F | +!! | tot_ngw | time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave | time integral of momentum flux due to nonstationary gravity waves | Pa | 1 | real | kind_phys | inout | F | +!! | du3dt_mtb | time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag | time integral of change in x wind due to mountain blocking drag | m s-2 | 2 | real | kind_phys | inout | F | +!! | du3dt_ogw | time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag | time integral of change in x wind due to orographic gw drag | m s-2 | 2 | real | kind_phys | inout | F | +!! | du3dt_tms | time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag | time integral of change in x wind due to TOFD | m s-2 | 2 | real | kind_phys | inout | F | +!! | du3dt_ngw | time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave | time integral of change in x wind due to NGW | m s-2 | 2 | real | kind_phys | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif + + + subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & + gw_dudt, 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, & + cnvgwd, 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 + logical, intent(inout) :: cnvgwd !< flag to turn on/off convective gwd + + real(kind=kind_phys), intent(in), dimension(im) :: zmtb, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw + real(kind=kind_phys), intent(in), dimension(im, levs) :: gw_dudt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (ldiag_ugwp)) return + + + 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 + endif + + + cnvgwd = .false. + + end subroutine cires_ugwp_post_run + +!> \section arg_table_cires_ugwp_post_finalize Argument Table +!! + subroutine cires_ugwp_post_finalize () + end subroutine cires_ugwp_post_finalize + +!! @} +end module cires_ugwp_post diff --git a/physics/cires_ugwp_solvers.F90 b/physics/cires_ugwp_solvers.F90 new file mode 100644 index 000000000..daba9b4c7 --- /dev/null +++ b/physics/cires_ugwp_solvers.F90 @@ -0,0 +1,664 @@ +! GW SOLVERS: +!=========== SOLVER_ORODIS; SOLVER_WMSDIS, SOLVER_LSATDIS +! + RF_DAMP if it is needed along with ugwp_tofd +!=========== +! Note in contrast to dycore vertical indices: surface=1 top=levs +! +! Collection of main friction-GWD solvers +! +! subroutine ugwp_oro +! +! subroutine gw_solver_linsatdis +! subroutine gw_solver_wmsdis +! subroutine rf_damp +! +! =========== +! +! + subroutine ugwp_oro(im, levs, dtp, kdt,me, lprnt, fcor, c2f2, & + u, v, tkin, pint, delp, pmid, pexner, gzint, gzmid, orostat, & + hpbl, axz, ayz, edis, kdis, dusfc, dvsfc, & + dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, dusfc_lwb, dvsfc_lwb, & + zmtb, zlwb, zogw, tauf_ogw, tauz_ogw, axmtb, axlwb, axtms ) +!---------------------------------------------------------------------- +! COORDE-output: 6-hour inst: U, V, T, PMSL, PS, HT (ounce) +! 3D 6-hr aver: DYN-U, SSO-U, PBL-U, AF-U1.... +! 2D 6-hr aver: tau_SSO, tau_GWD, tau_BL; & +! tau_sso = tau_mtb + tau_tofd + tau_lwb +tau_ogw +! ZM 6-hr aver: tau_RES = PS*dH/dx -zonal mean +! Experiments: Midlat 80-200km +! LR_CTL; ; LR_NOSSO with TOFD/TMS; +! LR_NOGWD (MTN+TOFD); LR_GWD4 --- 4 times taub +!---------------------------------------------------------------------- + use machine , only : kind_phys + use ugwp_oro_init, only : cdmb, cleff, sigfac, hncrit, hpmin, hminmt + use ugwp_oro_init, only : gamm_std, sigma_std + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + + + use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 + + use cires_ugwp_module, only : kxw, max_kdis, max_axyz + + implicit none + logical :: lprnt + integer :: im, levs + integer :: me + integer :: kdt + real(kind_phys) :: dtp + real(kind_phys), dimension(im) :: hpbl ! pbl-height in meters + real(kind_phys), dimension(im) :: fcor, c2f2 + real(kind_phys), dimension(im, 14) :: orostat + real(kind_phys), dimension(im, levs) :: u, v, tkin, q + + real(kind_phys), dimension(im, levs) :: pmid, pexner, gzmid, delp + real(kind_phys), dimension(im, levs+1) :: pint, gzint + + + real(kind_phys), dimension(im, levs) :: axz, ayz, edis, kdis ! total 6-hr averaged tendencies + real(kind_phys), dimension(im, levs) :: krf2d + real(kind_phys), dimension(im, levs) :: tauz_ogw, axmtb, axlwb, axtms ! 3-sub components axogw = axz-(axmtb+axlwb+axtms) + real(kind_phys), dimension(im) :: tauf_ogw ! total-source momentum flux + + real(kind_phys), dimension(im) :: zmtb, zlwb, zogw + + real(kind_phys), dimension(im) :: dusfc, dvsfc ! total tausfc_sso + real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb ! integrated tau_mtb + real(kind_phys), dimension(im) :: dusfc_ogw, dvsfc_ogw ! integrated tau_ogw + real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb ! integrated tau_lwb + real(kind_phys), dimension(im) :: dusfc_tofd, dvsfc_tofd ! integrated tau_tofd + +! +! mu=hprime gamm=a/b sigma theta +! which stand for the standard deviation, the anisotropy, the slope and the orientation of the orography. +! + real(kind_phys) :: elvmax(im) + real(kind_phys) :: hprime(im) + + real(kind_phys) :: theta !the orienatation, angle + real(kind_phys) :: sigma !the slope dh/dx + real(kind_phys) :: gamm !the anisotropy see ifs-oro + + real(kind_phys) :: oc, oa4(4), clx4(4) !kim & doyle 2005 .... attempt to do TOFD ..? +! + integer, allocatable :: k_elev(:), k_mtb(:), k_ogw(:), k_lee(:), k_tofd(:) + + real(kind_phys) wk(im) + + real(kind_phys) eng0, eng1 +! +! +! + real(kind_phys), dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid1, pex + + real(kind_phys), dimension(levs+1) :: taudz, rhoi, rim_z, pint1, zpi + real(kind_phys), dimension(levs) :: drtau, kdis_oro +! + real (kind_phys) :: elvp, elvpd, dtaux, dtauy + real(kind_phys) :: loss, mtb_fric, mbx, mby + real(kind_phys) :: sigflt + + real(kind_phys) :: zpbl = 2000. ! can be passed from PBL physics as in gwdps.f +! + logical icrilv(im) +! +!---- mountain/oro gravity wave drag +TOFD +! + real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1, epstofd1, krf_tofd1 +! + real(kind=kind_phys), dimension(levs) :: drlee, drmtb, drlow, drogw + real(kind_phys) :: r_cpdt, acc_lim + real(kind_phys), dimension(im) :: tautot, tauogw, taumtb, taulee, taurf + real(kind_phys) :: xn, yn, umag, kxridge, & + tx1, tx2 + real(kind=kind_phys),dimension(levs+1):: tau_src + + integer :: npt, krefj, kdswj, kotr, i, j, k + integer :: ipt(im) + +! +! copy 1D +! + do i=1, im + hprime(i) = orostat(i, 1) + elvmax(i) = orostat(i, 14) +! + tautot(i) = 0.0 + tauogw(i) = 0.0 + taumtb(i) = 0.0 + taulee(i) = 0.0 + taurf(i) = 0.0 +! + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + dusfc_mb(i) = 0.0 + dvsfc_mb(i) = 0.0 + dusfc_ogw(i) = 0.0 + dvsfc_ogw(i) = 0.0 + dusfc_lwb(i) = 0.0 + dvsfc_lwb(i) = 0.0 + dusfc_tofd(i) = 0.0 + dvsfc_tofd(i) = 0.0 + tauf_ogw(i) = 0.0 +! + zmtb(i) = -99. + zlwb(i) = -99. + zogw(i) = -99. + ipt(i) = 0 + enddo +! print *, maxval(hprime), maxval(elvmax), ' check hprime -elevmax ugwp_oro' +! +! 3-part of oro-effects + ked_oro +! + do k=1, levs + do i=1, im + axz(i,k) = 0.0 + ayz(i,k) = 0.0 + edis(i,k) = 0.0 + kdis(i,k) = 0.0 + krf2d(i,k) = 0.0 + tauz_ogw(i,k) = 0.0 + axmtb(i:,k) = 0.0 + axlwb(i,k) = 0.0 + axtms(i,k) = 0.0 + enddo + enddo + +! +! optional diag 3-parts of drag: [tx_ogw, tx_mtb, tx_lee] +! +! ----do we have orography for mtb and gwd calculation points ? +! + npt = 0 + do i = 1,im + if ( (elvmax(i) > hminmt) .and. (hprime(i) > hpmin) ) then + npt = npt + 1 + ipt(npt) = i + + endif + enddo + if (npt == 0) return ! no ororgraphy ====> gwd/mb calculation done + +! allocate(iwklm(npt), idxzb(npt), kreflm(npt)) + allocate( k_elev(npt), k_mtb(npt), k_ogw(npt), k_lee(npt), k_tofd(npt)) + do i=1,npt + k_ogw (i) = 2 + k_tofd(i) = 2 + k_lee (i) = 2 + k_mtb(i) = 0 + k_elev(i) = 2 + enddo +! +! controls through: use ugwp_oro_init +! main ORO-loop sigfac = n*sigma = [1.5, 2, 2.5, 4]*hprime +! + + + do i = 1, npt +! + j = ipt(i) + + elvpd = elvmax(j) + elvp = min (elvpd + sigfac * hprime(j), hncrit) + + sigma = orostat(j,13) + gamm = orostat(j,12) + theta = orostat(j,11)*deg_to_rad + + if (sigma == 0.0 ) then + sigma = sigma_std + gamm = gamm_std + theta = 0.0 + endif + + oc = orostat(j,2) + oa4(1) = orostat(j,3) + oa4(2) = orostat(j,4) + oa4(3) = orostat(j,5) + oa4(4) = orostat(j,6) + clx4(1) = orostat(j,7) + clx4(2) = orostat(j,8) + clx4(3) = orostat(j,9) + clx4(4) = orostat(j,10) +! +! do column-based diagnostics "more-efficient" for oro-places +! + + do k=1,levs + up(k) = u(j,k) + vp(k) = v(j,k) + tp(k) = tkin(j,k) + qp(k) = q(j,k) + dp(k) = delp(j,k) + + zpm(k) = gzmid(j,k) * rgrav + pmid1(k) = pmid(j,k) + pex(k) = pexner(j,k) + enddo + do k=1,levs+1 + zpi(k) = gzint(j,k) * rgrav + pint1(k) = pint(j,k) + enddo +! +! elvp- k-index: iwklm k_elvp = index for elvmax + 4*hprime, "elevation index" +! GFS-2017 + do k=1, levs-1 + if (elvp <= zpi(k+1) .and. elvp > zpi(k)) then + k_elev(i) = k+1 !......simply k+1 next interface level + exit + endif + enddo +! if (elvp .ge. 300. ) then +! write(6,333) elvp, zpi(1), elvpd, hprime(j), sigfac, hncrit +! pause +! endif +!333 format(6(3x, F10.3)) +! +! SSO effects: TOFD-drag/friction coefficients can be calculated +! + sigflt = hprime(j)*0.01 ! turb SSo(j) ...small-scale orography < 2-5 km .... + zpbl = hpbl(j) + + call ugwp_tofd1d(levs, sigflt, elvPd, zpi(1), zpbl, up, vp, zpm, & + utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1, levs + krf2d(j,k) = krf_tofd1(k) + axtms(j,k) = utofd1(k) +!------- +! nullify ORO-tendencies +! + drmtb(k) = 0.0 + drlee(k) = 0.0 + drtau(k) = 0.0 + drlow(k) = 0.0 + enddo + +!------- +! +! levels of k_mtb(i)/mtb + kdswj/dwlee + krefj/ogwd inside next "subs" +! zmtb, zlwb, zogw +! drmtb, drlow/drlee, drogw +!------- +! +! mtb : drmtb => 1-st order friction as well as TurbulentOro-Drag +! + call ugwp_drag_mtb( k_elev(i), levs, & + elvpd, elvp, hprime(j), sigma, theta, oc, oa4, clx4, gamm, zpbl, & + up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, k_mtb(i), drmtb, taumtb(j)) + + axmtb(j,1:levs) = drmtb(1:levs)*up(1:levs) +! +! print * , k_elev(i), k_mtb(i) , taumtb(j)*1.e3, ' k_elev, k_mtb , taumtb ' +! +! tautot = taulee+tauogw + rho*drlee = -d[taulee(z)]/dz +! + + + call ugwp_taub_oro(levs, k_mtb(i), kxw, taumtb(j), fcor(j), & + hprime(j) , sigma, theta, oc, oa4, clx4, gamm, elvp, & + up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, xn, yn, umag, & + tautot(j), tauogw(j), taulee(j), drlee, tau_src, & + kxridge, kdswj, krefj, kotr) + +! print *, k_mtb(i), kxw, taumtb(j), fcor(j),hprime(j), ' af ugwp_taub_oro ' +! print *, kdswj, krefj, kotr, ' kdswj, krefj, kotr ' + + + tauf_ogw(j) = tautot(j) + axlwb(j,1:levs) = drlee(1:levs) + + if ( k_mtb(i) > 0) zmtb(j) = zpi(k_mtb(i))- zpi(1) + if ( krefj > 0) zogw(j) = zpi(krefj) - zpi(1) + if ( kdswj > 0) zlwb(j) = zpi(kdswj) - zpi(1) +! if ( k_mtb(i) > 0 .and. zmtb(j) > zogw(j)) print *, ' zmtb > zogw ', zmtb(j), zogw(j) +! +! tau: tauogw, kxw/kxridge ATTENTION c2f2(j) = fcor(j)*fcor(j)/kxridge/kxridge +! + if ( (krefj > 1) .and. ( abs(tauogw(j)) > 0.) ) then +! + call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & + fcor(j), kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & + xn, yn, umag, drtau, kdis_oro) +! + else + drtau = 0. + endif + + tauz_ogw(j,1:levs) = tau_src(1:levs) + + r_cpdt = rcpd2/dtp +! +! + do k = 1,levs +! +! project to x-dir & y=dir and do diagnostics +! & apply limiters and output separate oro-effects +! + drlow(k) = drtau(k) + drlee(k) + acc_lim = min(abs(drlow(k)), max_axyz) + drlow(k) = sign(acc_lim, drlow(k)) + + dtaux = drlow(k) * xn + utofd1(k) + dtauy = drlow(k) * yn + vtofd1(k) + + eng0 = up(k)*up(k)+vp(k)*vp(k) + eng1 = 0.0 +! + if (k < k_mtb(i) .and. drmtb(k) /= 0 ) then + loss = 1.0 / (1.0+drmtb(k)*dtp) + mtb_fric = drmtb(k)*loss +! + mbx = mtb_fric * up(k) + mby = mtb_fric * vp(k) +! + ayz(j,k) = -mby !+ ayz(j,k) + axz(j,k) = -mbx !+ axz(j,k) +! + eng1 = eng0*loss*loss +eng1 + dusfc(j) = dusfc(j) - mbx * dp(k) + dvsfc(j) = dvsfc(j) - mby * dp(k) + endif +! + ayz(j,k) = dtauy + ayz(j,k) + axz(j,k) = dtaux + axz(j,k) +! + tx1 = u(j,k) + dtaux*dtp + tx2 = v(j,k) + dtauy*dtp + eng1 = tx1*tx1 + tx2*tx2 + eng1 + + dusfc(j) = dusfc(j) + dtaux * dp(k) + dvsfc(j) = dvsfc(j) + dtauy * dp(k) + + edis(j,k) = max(eng0-eng1, 0.0) * r_cpdt !+ epstofd1(k) + kdis(j,k) = min(kdis_oro(k), max_kdis ) + + enddo +! + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) +! +! oro-locations +! + enddo ! ipt - oro-loop .... "fraction of Land" in the grid box + deallocate(k_elev, k_mtb, k_ogw, k_lee, k_tofd ) +! + end subroutine ugwp_oro +! +! + subroutine gw_solver_linsatdis(im, levs, dtp, kdt, me, & + taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & + fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & + ax, ay, eps, ked, tauz) + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 + + use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps + use cires_ugwp_module, only : kvg, ktg, krad, kion + + implicit none + integer :: im, levs + integer :: me, kdt, nw, naz, nf_src + real :: dtp + integer, dimension(im) :: klev, if_src + real, dimension(im) :: taub, fcor, c2f2 + + real, dimension(naz) :: xaz, yaz + real, dimension(nw ) :: ch, spf +!========================== + real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q + real, dimension(im, levs+1) :: prsi , phii +!========================== + real, dimension(im, levs) :: ax, ay, eps, ked, tauz + + real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, & + q1, rho + real, dimension(levs+1) :: pint , zint, ui, vi, ti, & + bn2i, bvi, rhoi + integer :: i, j, k, ksrc + real, dimension(nw) :: taub_spect +! real, dimension(levs) :: ax1, ay1, eps1 +! real, dimension(levs+1) :: ked1, tau1 + real :: chm, ss + real, parameter :: dsp = 1./20. + logical :: pfirst=.true. + + save pfirst +128 Format (2x, I4, 4(2x, F10.3)) + +! do i=1, nw +! spf(i) = exp(-Ch(i)*dsp) +! enddo +! ss = sum(spf) +! spf(1:nw) = spf(1:nw)/ss + + if (pfirst ) then + j = 1 + ksrc = klev(j) + taub_spect(1:nw) = spf(1:nw)*taub(j) + print * + chm = 0. + do i=1, nw + write(6, 128) i, spf(i), taub_spect(i)*1.e3, ch(i), ch(i)-chm + chm = ch(i) + enddo + + print * + pause + endif + + do j=1,im + if (if_src(j) == 1) then +! +! compute GW-effects +! prsi, delp, prsl, prslk, phii, phil +! + do k=1,levs + u1(k) = u(j,k) + v1(k) = v(j,k) + t1(k) = t(j,k) + q1(k) = q(j,k) ! H2O-index -1 in tracer-array + dp(k) = delp(j,k) + + zmid(k) = phil(j,k) * rgrav + pmid(k) = prsl(j,k) +! pex1(k) = prslk(j,k) + enddo + do k=1,levs+1 + zint(k) = phii(j,k) * rgrav + pint(k) = prsi(j,k) + enddo + + call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) +! + ksrc = klev(j) + taub_spect(1:nw) = spf(1:nw)*taub(j)/rhoi(ksrc) + if (pfirst .and. j ==1 ) then + + print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' + print *, maxval(zmid), minval(zmid) , ' zmid ' + print *, maxval(zint), minval(zint) , ' zint ' + print *, maxval(rho), minval(rho) , ' rho ' + print *, maxval(rhoi), minval(rhoi) , ' rhoi ' + print *, maxval(ti), minval(ti) , ' tempi ' + print *, maxval(ui), minval(ui) , ' ui ' + print *, maxval(u1), minval(u1) , ' ++++ u1 ' + print *, maxval(vi), minval(vi) , ' vi ' + print *, maxval(v1), minval(v1) , ' ++++ v1 ' + print *, maxval(pint), minval(pint) , ' pint ' + pause + endif +! + call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, & + ch, xaz, yaz, fcor(j), c2f2(j), dp, & + zmid, zint, pmid, pint, rho, ui, vi, ti, & + kvg, ktg, krad, kion, bn2i, bvi, rhoi, & + ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & + ked(j,1:levs), tauz(j,1:levs)) +! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) + + if (pfirst .and. j ==1 ) then + + print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' + print *, maxval(zmid), minval(zmid) , ' zmid ' + print *, maxval(zint), minval(zint) , ' zint ' + print *, maxval(rho), minval(rho) , ' rho ' + print *, maxval(rhoi), minval(rhoi) , ' rhoi ' + print *, maxval(ti), minval(ti) , ' rhoi ' + print *, maxval(ui), minval(ui) , ' ui ' + print *, maxval(vi), minval(vi) , ' vi ' + print *, maxval(pint), minval(pint) , ' pint ' + pause + endif +! +! ax(j,:) = ax1 +! ay(j,:) = ay1 +! eps(j,:) = eps1 +! ked(j,:) = ked1(1:levs) +! tauz(j,:) = tau1(1:levs) + endif + + enddo + pfirst = .false. +! +! spectral solver for discrete spectra of GWs in N-azimiths +! Linear saturation with background dissipation +! + end subroutine gw_solver_linsatdis +! + subroutine gw_solver_wmsdis(im, levs, dtp, kdt, me, & + taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & + fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & + ax, ay, eps, ked, tauz) +! use para_taub, only : tau_ex + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 + + use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps + use cires_ugwp_module, only : kvg, ktg, krad, kion + + implicit none + integer :: im, levs, me, kdt, nw, naz, nf_src + real :: dtp + + integer, dimension(im) :: klev, if_src + real, dimension(im) :: taub, fcor, c2f2 + + real, dimension(naz) :: xaz, yaz + real, dimension(nw ) :: ch, spf +!========================== + real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q + real, dimension(im, levs+1) :: prsi , phii +!========================== + real, dimension(im, levs) :: ax, ay, eps, ked, tauz + + real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, q1, rho + real, dimension(levs+1) :: pint , zint, ui, vi, ti, bn2i, bvi, rhoi + + integer :: i, j, k, ksrc + real, dimension(nw) :: taub_spect +! real, dimension(levs) :: ax1, ay1, eps1 +! real,dimension(levs+1) :: ked1, tau1 + real :: tau_ex + +! print *, nf_src, 'nf_src ... gw_solver_wmsdis ' +! print *, if_src, 'if_src ... gw_solver_wmsdis ' + + do j=1,im + if (if_src(j) == 1) then +! +! compute gw-effects +! prsi, delp, prsl, prslk, phii, phil +! + do k=1,levs + u1(k) = u(j,k) + v1(k) = v(j,k) + t1(k) = t(j,k) + q1(k) = q(j,k) ! h2o-index -1 in tracer-array + dp(k) = delp(j,k) + + zmid(k) = phil(j,k) *rgrav + pmid(k) = prsl(j,k) +! pex1(k) = prslk(j,k) + enddo + do k=1,levs+1 + zint(k) = phii(j,k)*rgrav + pint(k) = prsi(j,k) + enddo + + call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) +! +! any extras bkg-arrays +! + ksrc = klev(j) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! more work for spectral setup for different "slopes" +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + tau_ex = taub(j) + taub_spect(1:nw) = spf(1:nw)/rhoi(ksrc) *tau_ex ! check it ....*tau_ex(j) + +! +! call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) +! +! print *, ' bf ugwp_wmsdis_naz ksrc', ksrc, zmid(ksrc) + + call ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, tau_ex, ch, xaz, yaz, & + fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, & + rho, ui, vi, ti, kvg, ktg, krad, kion, bn2i, bvi, & + rhoi, ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & + ked(j,1:levs), tauz(j,1:levs)) +! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) + +! print *, ' after ugwp_wmsdis_naz ksrc', ksrc, zint(ksrc) + +! subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & +! fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & +! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked) + +! ax(j,:) = ax1 +! ay(j,:) = ay1 +! eps(j,:) = eps1 +! ked(j,:) = ked1(1:levs) +! tauz(j,:) = tau1(1:levs) + + endif + + enddo +! +! ugwp_wmsdis_naz everything similar to linsat , except spectral saturation +! +! + return + end subroutine gw_solver_wmsdis +! +! + subroutine rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, u, v, ax, ay, eps) + use ugwp_common, only : rcpd2 + + implicit none + + integer :: im, levs, levs_rf + real :: dtp + real, dimension(levs) :: rfdis, rfdist + real, dimension(im, levs) :: u, v, ax, ay, eps + real :: ud, vd, rdtp + integer :: i, k + + rdtp = 1.0 / dtp + + do k= levs_rf, levs + do i=1,im + ud = rfdis(k)*u(i,k) + vd = rfdis(k)*u(i,k) + ax(i,k) = rfdist(k)*u(i,k) + ay(i,k) = rfdist(k)*v(i,k) + eps(i,k) = rcpd2*(u(i,k)*u(i,k) +v(i,k)*v(i,k) -ud*ud -vd*vd) + enddo + enddo + end subroutine rf_damp +! diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 new file mode 100644 index 000000000..07782e44d --- /dev/null +++ b/physics/cires_ugwp_triggers.F90 @@ -0,0 +1,573 @@ + subroutine ugwp_triggers + implicit none + write(6,*) ' physics-based triggers for UGWP ' + end subroutine ugwp_triggers +! + SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + use ugwp_common , only : deg_to_rad + + implicit none + integer :: nx, ny + real :: lon(nx), lat(ny) + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + real :: earth_r, ra1, ra2, dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + integer :: j +! +! specify common constants and +! geometric factors to compute deriv-es etc ... +! coriolis coslat tan etc... +! + earth_r = 6370.e3 + ra1 = 1.0 / earth_r + ra2 = ra1*ra1 +! + rlat = lat*deg_to_rad + rlon = lon*deg_to_rad + tanlat = atan(rlat) + cosv = cos(rlat) + dy = rlat(2)-rlat(1) + dx = rlon(2)-rlon(1) +! + + do j=1, ny-1 + rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) + enddo + + +! + + do j=2, ny-1 + brcos(j) = 1.0 / cos(rlat(j))*ra1 + enddo + + brcos(1) = brcos(2) + brcos(ny) = brcos(ny-1) + brcos2 = brcos*brcos +! + dlam1 = brcos / (dx+dx) + dlam2 = brcos2 / (dx*dx) + + dlat = ra1 / (dy+dy) + + divJp = dlat*cosv + divJM = dlat*cosv +! + do j=2, ny-1 + divJp(j) = dlat*cosv(j+1)/cosv(j) + divJM(j) = dlat*cosv(j-1)/cosv(j) + enddo + divJp(1) = divjp(2) !*divjp(1)/divjp(2) + divJp(ny) = divjp(1) + divJM(1) = divjM(2) !*divjM(1)/divjM(2) + divJM(ny) = divjM(1) +! + return + end SUBROUTINE subs_diag_geo +! + subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! compute for each Vert-column: grad(V) +! periodic in X and central diff ... +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Vx(nx, ny), Vy(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) + + end subroutine get_xy_pt + + subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) +! +! compute for each Vert-column: grad(V) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Divjp(ny), Divjm(ny) + real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) +!~~~~~~~~~~~~~~~~~~~~ +! 1/cos*d(vcos)/dy +!~~~~~~~~~~~~~~~~~~~~ + do j=2, ny-1 + Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) + enddo + Vyd(:, 1) = Vyd(:,2) + Vyd(:,ny) = Vyd(:,ny-1) + + end subroutine get_xyd_wind + + subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_fgf +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + + enddo + end subroutine trig3d_fjets + + subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_okw +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2, d1 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 + W2 = (Vx - Uyd)*(Vx - Uyd) + D1 = Ux + Vyd + trig3d_okw(:,:,k) = W1 -W2 +! trig3d_okw(:, :, k) =S2 -W2 +! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean +! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk + enddo + end subroutine trig3d_okubo +! + subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_conv + + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + integer :: k + end subroutine trig3d_dconv + + subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & + U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & + trig3d_okw, trig3d_fgf, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! +! reversed ??? Hyai, Hybi , pmid +! + real, dimension(nz+2) :: Hyai, Hybi + real, dimension(nz+1) :: Hyam, Hybm +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS, HS + real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + real :: dzkm, zkm + integer :: k +!================================================================================== +! fgf and OW-triggers +! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! +! +!=================================================================================== + + call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) + call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) + call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) +!===================================================================================================== +! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d +! +! Bulk momentum flux=/ 0 and levels for launches +! +!===================================================================================================== + 111 format(i6, 4(3x, F8.3), ' trigger-grid ') + + do k=1, nz-1 + zkm = -7.*alog(pmid(k)*1.e-3) + dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) + write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' + enddo + + end subroutine cires_3d_triggers +!================================================================================== +! tot-flux launch 0 or 1 # of Launches +! specify time-dep bulk sources: taub, klev, if_src, nf_src +! +!================================================================================== + subroutine get_spectra_tau_convgw & + (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) +! +! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function +! + integer :: nw, im, levs + integer,dimension(im,3) :: icld + real, dimension(im, levs) :: dcheat, scheat + real, dimension(im) :: precip, xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real, parameter :: precip_max = 100. ! mm/day + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + + integer :: i, k, klow, ktop, kmid + real :: dtot, dmax, daver +! + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + do i=1, im + klow = icld(i,1) + ktop = icld(i,2) + kmid= icld(i,3) + if (klow == -99 .and. ktop == -99) then + cycle + else + klev(i) = ktop + k = klow + klev(i) = k + dmax = abs(dcheat(i,k) + scheat(i,k)) + do k=klow+1, ktop + dtot =abs(dcheat(i,k) + scheat(i,k)) + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! +! klev as max( dcheat(i,k) + scheat) +! vertical width of conv-heating +! +! counts/triiger=1 & taub(i) +! + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_amp* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! 100 mb launch and MERRA-2 slat-forcing +! + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo + +! with info on precip/clouds/dc_heat create Bulk +! taub(im), klev(im) +! +! print *, ' get_spectra_tau_convgw ' + end subroutine get_spectra_tau_convgw +! + subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_fgf +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1.0 / float(kwidth) + tau_min = tau_amp*fnorm + do i=1, im +! +! only trop-c fjets so find max(trig_fgf) => klev +! use abs-values to scale tau_amp +! + + k = klow + klev(i) = k + dmax = abs(trig_fgf(i,k)) + kex = 0 + if (dmax >= tlim_fgf) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_fgf(i,k)) + if (dtot >= tlim_fgf) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo + + if (dmax .ge. tlim_fgf) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! print *, ' get_spectra_tau_nstgw ' + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo +! + end subroutine get_spectra_tau_nstgw +! + subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_okw +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1./float(kwidth) + tau_min = tau_amp*fnorm + print *, ' get_spectra_tau_okwgw ' + do i=1, im + k = klow + klev(i) = k + dmax = abs(trig_okw(i,k)) + kex = 0 + if (dmax >= tlim_okw) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_okw(i,k)) + if (dtot >= tlim_fgf ) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! + if (dmax >= tlim_okw) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo + print *, ' get_spectra_tau_okwgw ' + end subroutine get_spectra_tau_okw +! +! +! + subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: xlatdeg(im), tau_amp + 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_tamp + + subroutine slat_geos5(im, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: xlatdeg(im) + real :: tau_gw(im) + real :: latdeg + real, parameter :: tau_amp = 100.e-3 + real :: trop_gw, flat_gw + integer :: i +! +! if-lat +! + trop_gw = 0.75 + do i=1, im + latdeg = xlatdeg(i) + if (-15.3 < latdeg .and. latdeg < 15.3) then + flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) + if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw + else if (latdeg > -31. .and. latdeg <= -15.3) then + flat_gw = 0.10 + else if (latdeg < 31. .and. latdeg >= 15.3) then + flat_gw = 0.10 + else if (latdeg > -60. .and. latdeg <= -31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg < 60. .and. latdeg >= 31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg <= -60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + else if (latdeg >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + end if + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5 + subroutine init_nazdir(naz, xaz, yaz) + use ugwp_common , only : pi2 + implicit none + integer :: naz + real, dimension(naz) :: xaz, yaz + integer :: idir + real :: phic, drad + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir diff --git a/physics/cires_ugwp_utils.F90 b/physics/cires_ugwp_utils.F90 new file mode 100644 index 000000000..63a5b3238 --- /dev/null +++ b/physics/cires_ugwp_utils.F90 @@ -0,0 +1,152 @@ +! + subroutine um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, bn2, uhm, vhm, bn2hm, rhohm) +! + use ugwp_common, only : bnv2min, grav, gocp, fv, rdi + implicit none +! +! mass-averaged variables between klow-ktop +! + integer, intent(in) :: nz, klow, ktop + real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid + real, dimension(nz+1), intent(in) :: pint, zpi + real, dimension(nz), intent(out) :: bn2 + + real :: vtj, rhok, bnv2, rdz + real :: vtkp, vtk, dzp, rhm,dphm + + real, intent(out) :: uhm, vhm, bn2hm, rhohm + + integer :: k +! + dphm = 0.0 !pint(k+1)-pint(k)) + + uhm = 0.0 ! dphm*u1(k) + vhm = 0.0 ! dphm*v1(k) + rhm = 0.0 ! + bn2hm = 0.0 ! +! + do k=klow, ktop + vtj = tp(k) * (1.+fv*qp(k)) + vtk = vtj + vtkp = tp(k+1) * (1.+fv*qp(k+1)) + rhok = rdi * pmid(k) / vtj ! density kg/m**3 + rdz = 1.0 / (zpm(k+1)-zpm(k)) +! dry +! bnv2 = grav * (rdz * ( tp(k+1)-tp(k)) +grcp) /tp(k) +! +! wet +! + bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtk +! if (bnv2 < 0) print *, k, bnv2, ' bnv2 < 0 ', klow, ktop + bnv2 = max(bnv2, bnv2min ) + dzp = pint(k+1)-pint(k) + + dphm = dphm + dzp + uhm = uhm + up(k)*dzp + vhm = vhm + vp(k)*dzp + rhm = rhm + rhok*dzp + bn2hm = bn2hm + bnv2 * dzp + bn2(k) = bnv2 + enddo + + uhm = uhm/dphm + vhm = vhm/dphm + rhm = rhm/dphm + bn2hm = bn2hm/dphm + rhohm = rhm/dphm +! +! print *, ' MF-BV ', bn2hm, bn2(ktop), bn2(klow) +! + end subroutine um_flow +! +! + subroutine mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + use ugwp_common, only : bnv2min, grav, gocp, fv, rdi + + implicit none + + integer :: levs + real, dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid + real, dimension(levs+1) :: pint, rho, zpi + real, dimension(levs) :: zdelpi, zdelpm + real :: zul, bvl + real, dimension(levs+1) :: ui, vi, bn2i, bvi, rhoi, ti, qi + + real :: vtj, rhok, bnv2, rdz + real :: vtkp, vtk, dzp + real :: vtji + integer :: k +! +! get interface values from surf to top +! + do k=2,levs + vi(k) = 0.5 *(vp(k-1) + vp(k)) + ui(k) = 0.5 *(up(k-1) + up(k)) + ti(k) = 0.5 *(tp(k-1) + tp(k)) + qi(k) = 0.5 *(qp(k-1) + qp(k)) + enddo + + k=1 + ti(k) = tp(k) + ui(k) = up(k) + vi(k) = vp(k) + qi(k) = qp(k) + k= levs + ti(k+1) = tp(k) + ui(k+1) = up(k) + vi(k+1) = vp(k) + qi(k+1)=qp(k) + + do k=1,levs-1 + vtj = tp(k) * (1.+fv*qp(k)) + vtji = ti(k) * (1.+fv*qi(k)) + rho(k) = rdi * pmid(k) / vtj ! density kg/m**3 + rhoi(k) = rdi * pint(k) / vtji + vtk = vtj + vtkp = tp(k+1) * (1.+fv*qp(k+1)) + rdz = 1. / ( zpm(k+1)-zpm(k)) + bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtji + bn2i(k) = max(bnv2, bnv2min ) + bvi(k) = sqrt( bn2i(k) ) + vtk = vtkp + enddo + k = levs + vtj = tp(k) ! * (1.+fv*qp(k)) + vtji = ti(k) !* (1.+fv*qi(k)) + rho(k) = rdi * pmid(k) / vtj + rhoi(k) = rdi * pint(k) / vtji + bn2i(k) = bn2i(k-1) + bvi(k) = sqrt( bn2i(k) ) + k = levs+1 + rhoi(k) = rdi * pint(k) / ti(k) + bn2i(k) = bn2i(k-1) + bvi(k) = sqrt( bn2i(k) ) +! do k=1,levs +! write(6, 121) k, zpm(k)*1.e-3, zpi(k)*1.e-3, bvi(k), rho(k), rhoi(k) +! enddo + 121 format(i5, 2x, 3(2x, F10.3), 2(2x, E10.3)) + + end subroutine mflow_tauz + +! + subroutine get_unit_vector(u, v, u_n, v_n, mag) + implicit none + real, intent(in) :: u, v + real, intent(out) :: u_n, v_n, mag +! + + mag = sqrt(u*u + v*v) + + if (mag > 0.0) then + u_n = u/mag + v_n = v/mag + else + u_n = 0. + v_n = 0. + end if + + end subroutine get_unit_vector +! diff --git a/physics/cires_vert_lsatdis.F90 b/physics/cires_vert_lsatdis.F90 new file mode 100644 index 000000000..a44b8dde0 --- /dev/null +++ b/physics/cires_vert_lsatdis.F90 @@ -0,0 +1,524 @@ + subroutine ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & + fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & + kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) +! +! call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & +! fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & +! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1) + use ugwp_common, only : rcpd, grav, rgrav + implicit none +! + integer :: levs, nw, naz, ksrc + real :: kxw + real, dimension(nw) :: taub_spect, ch + real, dimension(naz) :: xaz, yaz + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint + real, dimension(levs ) :: dp, rho, pmid, zmid + real :: fcor, c2f2 + real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol + +! output/locals + real, dimension(levs ) :: ax, ay, eps + real, dimension(levs+1) :: ked , tau1 + + real, dimension(levs+1 ) :: uaz + real, dimension(levs, naz ) :: epsd + real, dimension(levs+1, naz ) :: atau, kedd + real, dimension(levs+1 ) :: taux, tauy + real, dimension(levs ) :: dzirho , dzpi + real :: usrc +! + integer :: iaz, k +! + atau=0.0 ; epsd=0.0 ; kedd=0.0 + + do k=1,levs + dzpi(k) = -(pint(k+1)-pint(k))/rho(k)*rgrav + dzirho(k) = 1./rho(k)/dzpi(k) ! grav/abs(dp(k)) still hydrostatic "UGWP" + enddo + + LOOP_IAZ: do iaz =1, naz + usrc = ui(ksrc)*xaz(iaz) +vi(ksrc)*yaz(iaz) + do k=1,levs+1 + uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) -usrc + enddo +! +! if (nw .le. 4) call stochastic ..ugwp_lsatdis_az1 only 4-waves ch_ngw1, fuw_ngw1, eff_ngw1=1 +! +! multi-wave scheme +! + if (nw .gt. 4) then + call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & + fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & + kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) + + endif +! + ENDDO LOOP_IAZ ! Azimuth of GW propagation directions +! +! sum over azimuth and project aTau(z, iza) =>(taux and tauy) +! for scalars for "wave-drag vector" +! + eps =0. ; ked =0. + do k=ksrc, levs + eps(k) = sum(epsd(k,:))*rcpd + enddo + + do k=ksrc, levs+1 + taux(k) = sum( atau(k,:)*xaz(:)) + tauy(k) = sum( atau(k,:)*yaz(:)) + ked(k) = sum(kedd(k,:)) + enddo + + tau1(ksrc:levs) = taux(ksrc:levs) + tau1(1:ksrc-1) = tau1(ksrc) +! +! end solver: gw_azimuth_solver_LS81 +! sign Ax in rho*dU/dt = -d(rho*tau)/dz +! [(k) - (k+1)] + ax =0. ; ay = 0. + do k=ksrc, levs + ax(k) = dzirho(k)*(taux(k)-taux(k+1)) + ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) + enddo + call ugwp_limit_1d(ax, ay, eps, ked, levs) + return + +! + print * + print *, ' Ax: ', maxval(Ax(ksrc:levs))*86400., minval(Ax(ksrc:levs))*86400. + print *, ' Ay: ', maxval(Ay(ksrc:levs))*86400., minval(Ay(ksrc:levs))*86400. + print *, 'Eps: ', maxval(Eps(ksrc:levs))*86400., minval(Eps(ksrc:levs))*86400. + print *, 'Ked: ', maxval(Ked(ksrc:levs))*1., minval(Ked(ksrc:levs))*1. +! print *, 'Atau ', maxval(atau(ksrc:levs, 1:Naz))*1.e3, minval(atau(ksrc:levs, 1:Naz))*1.e3 +! print *, 'taux_gw: ', maxval(taux( ksrc:levs))*1.e3, minval(taux( ksrc:levs))*1.e3 + print * +!----------------------------------------------------------------------- +! Here we can apply "ad-hoc" or/and "stability-based" limiters on +! (axy_gw, ked_gw and eps_gw) and check vert-inegrated conservation laws: +! energy and momentum and after that => final update gw-phys tendencies +!----------------------------------------------------------------------- + + end subroutine ugwp_lsatdis_naz +! + subroutine ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_sp, & + fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, & + dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) + +! call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & +! fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & +! kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) + + use cires_ugwp_module, only : F_coriol, F_nonhyd, F_kds, linsat, linsat2 + use cires_ugwp_module, only : iPr_ktgw, iPr_spgw, iPr_turb, iPr_mol + use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim +! + implicit NONE +! + integer, intent(in) :: nw ! number of GW modes in given direction + integer, intent(in) :: levs ! vertical layers + integer, intent(in) :: ksrc ! level of GW-launch layer + + real , intent(in) :: kxw ! horizontal wavelength + real , intent(in) :: ch(nw) ! horizontal phase velocities + real , intent(in) :: taub_sp(nw) ! spectral distribution of the mom-flux +! + real, intent(in) :: fcor, c2f2 ! Corilois factors + + real , intent(in) :: um(levs+1) + real , intent(in) :: tm(levs+1) +!in + real, intent(in), dimension(levs) :: rho, zm + real, intent(in), dimension(levs+1) :: rhoi, zi + real, intent(in), dimension(levs+1) :: bn2, bn + real, intent(in), dimension(levs) :: dzpi, dzirho + real, intent(in), dimension(levs+1) :: kvg, ktg, krad, kion, kmol +!======================================================================== +!out + real, dimension(levs+1) :: tau, ked + real, dimension(levs) :: eps + +!========================================================================= +!local + real :: Fd1, Fd2 + real, dimension(levs) :: a_mkz + real, dimension(levs+1,nw) :: sp_tau, sp_ked, sp_kth + real, dimension(levs,nw) :: sp_eps + + real, dimension(levs,nw) :: sp_mkz, sp_etot + real, dimension(levs,nw) :: sp_ek, sp_ep + + + real, dimension(levs) :: swg_ep, swg_ek, swg_et, swg_kz + + real, dimension(nw) :: rtaus ! spectral distribution at ksrc + real :: sum_rtaus ! total flux in iaz-azimuth + real :: Chnorm, Cx, Cs, Cxs, Cx2sat + real :: Fdis, Fdisat + real :: Cdf2, Cdf1 ! (Cd*cd-f*f) and sqrt +! +! two-level => upward integration for wave-filtering (dissip + breaking) +! + real :: taus, tauk, tau_lin + real :: etws, etwk, etw_lin + real :: epss, epsk + real :: kds, kdk + real :: kzw, kzw2, kzw3, kzi, kzs + real :: wfd, wfi ! +! +! for GW dissipation on the rotational sphere +! + real :: Betadis ! Ep/Ek ratio + real :: BetaM, BetaT ! 0.5 or 1./1+b and 1-1/(1+b) + real :: wfdM, wfdT, wfiM, wfiT, wdop2 + + real :: dzi, keff, keff_m, keff_t, keffs + + real :: sf2k2, cf2 + real :: Lzkm, Lzsat + + integer :: i, k, igw + integer :: ksat1, ksat2 + + real :: zsat1, zsat2 + real :: kx2_nh + + real :: rab1, rab2, rab3, rab4, cd_ulim2 + + integer :: Ind_out(nw, levs+1) + +! + logical, parameter :: dbg_print = .false. +! +!=================================================================== +! Nullify arrays +! tau, eps, ked +!==================================================================== + + tau = 0.0 + eps = 0.0 + ked = 0.0 + Ind_out(1:nw,:) = 0 +! +! GW-spectral arrays ..... sp_etot ....sp_tau +! + sp_tau = 0. + sp_eps = 0. + sp_ked = 0. + sp_mkz = -99. + sp_etot = 0. + sp_ek = 0. + sp_ep = 0. + sp_kth = 0. +! + swg_et = 0. + swg_ep = 0. + swg_ek = 0. + swg_kz = 0. + cd_ulim2 = cd_ulim*cd_ulim + cf2 = F_coriol*c2f2 + kx2_nh = F_nonhyd*kxw*kxw + + if (dbg_print) then + write(6,*) linsat , ' eff-linsat & kx ', kxw + write(6,*) maxval(ch), minval(ch), ' ch ' + write(6,*) + write(6,*) maxval(rhoi), minval(rhoi), 'rhoi ' + write(6,*) zi(ksrc) , ' zi(ksrc) ' + write(6,*) cd_ulim, ' crit-level cd_ulim ' + write(6,*) F_coriol, ' F_coriol' + write(6,*) F_nonhyd, ' F_nonhyd ' + write(6,*) maxval(Bn), minval(BN), ' BN-BV ' + write(6,*) Um(ksrc), ' Um-ksrc ', cd_ulim2 , 'cd_ulim2 ', c2f2, ' c2f2 ' + pause + endif + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Loop_GW: over GW-spectra +! of individual non-interactive modes +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! + Loop_GW: do i=1, nw +! + Kds = 0.0 +! +! src-level +! + Cx = ch(i) - Um(ksrc) + Cdf2 = Cx*Cx - cf2 + taus = taub_sp(i) ! momentum flux for i-mode w/o rhoi(ksrc) + kzw = Bn(ksrc) / Ch(i) ! ch(i) > 0. Cx(i) < 0. critica + etws = taus*kzw / kxw + rtaus(i) = taus*rhoi(ksrc) +! + IF( Cx <= cd_ulim .or. Cdf2 <= cd_ulim2) THEN + Ind_out(i, ksrc) =-1 ! -1 - diagnostic index for critical levels + cycle Loop_GW ! got to the next mode of GW-spectra + ELSE +! + kzw2 = Bn2(ksrc)/Cdf2 - rhp4 - kx2_nh +! + if (kzw2 <= 0.) then + Ind_out(i, ksrc) =-2 ! -2 - diagnostic index for reflected waves + cycle Loop_GW ! no wave reflection in GW-LSD scheme + endif + + kzw = sqrt(kzw2) + kzw3 = kzw2*kzw + etws = taus*kzw/kxw +! +! Here Linsat == Fr_critical +! + Cx2sat = Linsat2*Cdf2 + if (etws >= cx2sat) then + Kds = kxw*Cx*rhp2/kzw3 + etws = cx2sat + taus = etws*kxw/kzw + Ind_out(i, ksrc) =-3 ! -3 - dignostic index for saturated waves + endif +! + betadis = cdf2/(Cx*Cx+cf2) + betaM = 1.0 /(1.0+betadis) + betaT = 1.0 - BetaM +! + Cxs = Cx + kzs = kzw +! keffs = (kvg(ksrc)+kds)*iPr_turb*.5*khp +! sp_kth(ksrc, i) = rhoi(ksrc)*keffs*(Tm(ksrc)+Tm(ksrc-1)) + rtaus(i) = taus*rhoi(ksrc) + sp_tau(ksrc, i) = rtaus(i) + sp_etot(ksrc, i) = etws + sp_mkz(ksrc, i) = kzw + sp_ek(ksrc, i) = etws*betam + sp_ep(ksrc, i) = etws*betaT ! can be transferred to (T'**2) T-rms + +! + ENDIF ! vertical propagation of i-mode to the next upper layer = (ksrc+1) +! +! Loop_Zint .................................. VERTICAL "INTERFACE" LOOP from ksrc => ktop_GW +! + Loop_Zi: do k=ksrc+1, levs +! + Cx = ch(i)-Um(k) ! Um(k) is defined at the interface pressure levels + Cdf2 = Cx*Cx -cf2 + if( Cx <= cd_ulim .or. Cdf2 <= 0.) then + Ind_out(i, k) =-1 ! 1 - diagnostic index for critical levels + ! print*,'crit level C-U ',int(Cx),int(sqrt(cf2)),' Um ',Um(k) + cycle Loop_GW + endif + + cdf1 =sqrt(Cdf2) + wdop2 = (kxw*Cx)* (kxw*Cx) + kzw2 = (Bn2(k)-wdop2)/Cdf2 - rhp4 - kx2_nh ! full lin DS-NIGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) + + if (kzw2 < 0.) then + Ind_out(i, k) =-2 ! 2 - diagnostic index for reflected waves + cycle Loop_GW + endif + kzw = sqrt(kzw2) + kzw3 =kzw2*kzw +! + keff_m = kvg(k)*kzw2 + kion(k) +! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol + keff_t = ktg(k)*kzw2 + krad(k) +! +! + betadis = cdf2 / (Cx*Cx+cf2) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + +! +!imaginary frequencies of momentum and heat with "kds at (k-1) level" +! + wfiM = kds*kzw2*F_kds + keff_m + wfiT = kds*iPr_ktgw*F_kds * kzw2 + keff_t +! + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cx)*BetaT +! exp-l: "kzi*dz" + kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) ! 2-factor energy-momentum (U')^2 +!------------------------------------------------------- +! dissipative factor: Fdis +! we can replace WKB-solver by Numerical integration of +! tau_gw == etot_gw/kzw*kxw +! d(rho*tau_gw) = -kdis*rho*tau_gw +! |tau_gw| <= |tau_gwsat| +! linear limit for single mode +! generalization for the "broad" spectra +! or treating single mode breaking +! over finite "vertical"-depth with "efficiency" +! Now: time-step + hor-l scale +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Fdis = exp(-kzi) +! +! +! dissipative "wave rms" by WKB +! + etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*kzw/kzs +! + Cx2sat = Linsat2*Cdf2 +! +! Linear saturation +! + if (etwk.ge.cx2sat) then + + Ind_out(i, k) =-3 ! 3 - dignostic index for saturated waves +! ! saturate energy and "trigger" keddy + etw_lin = etwk + etwk = cx2sat + Kds = kxw*Cdf1*rhp2/kzw3 + tauk = etwk*kxw/kzw + +!=================================================================================== +! WAM/case with high Kds tau_lin = (etw_lin-etwk)*kxw/kzw !tau_loss by sat theory +! Lzsat = 6,28/kzw Zsat1 = Zi(k)-.5*Lzsat +! Zsat2 = Zi(k)+.5*Lzsat +! in WAM triggering from "kds = 0 m2/s" => "200 m2/s" for Lzw ~ 10 km +! +! call sat_domain(zi, Zsat1, Zsat2, pver, ksat1, ksat2) +! +! to avoid it do the new diss-n factor with eddy "kds" added to the +! background keff_m and keff_t +! +! can be taken out for the strato-mesosphere in GFS +! wfiM = kds*kzw2 + keff_m +! wfiT = kds*iPr_ktgw * kzw2 +keff_t +! wfdM = wfiM/(kxw*Cdf1)*BetaM +! wfdT = wfiT/(kxw*Cx)*BetaT +! kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) +! Fdisat = exp(-kzi) +! etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*(kzw/Kzs) +! updated breaking in the Lzsat-domain: zsat1 < zi < zsat2 +! ================================================================================= + else + kds = 0.0 + tauk = etwk*kxw/kzw ! = Ekin*kx/kz + ENDIF +!-------------------------------------- +! +! Fill in spectral arrays(levs, nw) +! +!-------------------------------------- + sp_ked(k,i) = kds ! defined at interfaces + sp_tau(k, i) = tauk*rhoi(k) ! defined at interfaces + +! keff = (kds + kvg(k))*iPr_turb*0.5*KHP +! sp_kth(k, i) = rhoi(k)*keff*(Tm(k)+Tm(k-1)) ! defined at mid-layers + + sp_etot(k, i) = etwk ! defined at interfaces + sp_mkz(k, i) = kzw ! defined at interfaces + sp_ek(k, i) = etwk*betam ! defined at interfaces + sp_ep(k, i) = etwk*betaT ! can be transferred to (T'**2) +! +! + if (sp_tau(k,i) > sp_tau(k-1,i)) then + sp_tau(k,i) = sp_tau(k-1,i) ! prevent "possible" numerical "noise" + endif +! +! updates for "eps and keff" from +! + rab1 =.5*(cx+cxs)*dzirho(k) +! heating +! due to wave dissipation +! + sp_eps(k,i) = rab1*(sp_tau(k-1,i)- sp_tau(k,i)) ! defined at mid-layers +! +! cooling term due to eddy heat conduction =0 if Keff_cond =>0, +! usually updated by 1D-heat implict tridiagonal solver +! explicit local solver ---->sp_kth(k,i) = Kt*(dT/dz+ R/Cp*T/Hp~>g/cp) +! +! sp_eps(k,i)=sp_eps(k,i)+dzirho(k)*(sp_kth(k,i)- sp_kth(k-1,i)) +! + kzs = kzw + cxs = cX + taus = tauk + etws = etwk +! keffs = keff + + enddo Loop_Zi ! ++++++++++++++ vertical layer +! +! ................................! stop ' in solver single-mode' +! + enddo Loop_GW ! i-mode of GW-spectra +! + sum_rtaus =sum(rtaus) ! total momentum flux at k=ksrc + +! print *, sum_rtaus, ' tau-src ', nint(zi(ksrc)*1.e-3) +! print *, maxval(ch), minval(ch), ' Ch ', ngwv, ' N-modes ' +! +!============================================================================== +! Perform spectral integartion (sum) & apply "efficiency/inremittency" factors +! +! eff_factor: ~ 1./[number of modes in 1-direction of model columns] +! +!============================================================================== + do k=ksrc, levs + + ked(k) =0. + Eps(k) = 0. + Tau(k) = 0. + swg_et(k) =0. + swg_ep(k) =0. + swg_ek(k) =0. + + do i=1,nw + Ked(k) = Ked(k)+sp_ked(k,i) + Eps(k) = Eps(k)+sp_eps(k,i) + Tau(k) = Tau(k)+sp_tau(k,i) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! GW-energy + GW-en flux ~ Cgz*E, diagnostics-only +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + swg_et(k) = swg_et(k)+sp_etot(k,i) !*eff_fact + swg_ep(k) = swg_ep(k)+sp_ep(k,i) !*eff_fact + swg_ek(k) = swg_ek(k)+sp_ek(k,i) !*eff_fact + enddo + + enddo +! fill in below the "source" level ..... [1:ksrc-1] +! + do k=1, ksrc-1 +! no loss of the total momentum flux + ked(k) =0. + eps(k) = 0. + tau(k) = tau(ksrc) +! lin-theory diagnostics-only + swg_et(k) =swg_et(ksrc)*rhoi(ksrc)/rhoi(k) + swg_ep(k) =swg_ep(ksrc)*rhoi(ksrc)/rhoi(k) + swg_ek(k) =swg_ek(ksrc)*rhoi(ksrc)/rhoi(k) + enddo +! + RETURN +! +! diagnostics below +! +345 FORMAT(2x, F8.2, 4(2x, F10.3), 2x, F8.2) + if (dbg_print) then + print * + print *, ' Zkm EK m2/s2 Ked m2/s Eps m2/s3 tau-Mpa ' + do k=ksrc, levs +! Fd1 = maxval(Fdis_modes(1:nw,k)) +! Fd2 = minval(Fdis_modes(1:nw,k)) + write(6, 345) Zi(k)*1.e-3, sqrt(swg_ek(k)), Ked(k), Eps(k), Tau(k)*1.e3, Um(k) !, Fd1, Fd2 + enddo + print * + write(6,*) nw , ' nwaves-linsat ' + write(6,*) maxval(sp_ked), minval(sp_ked), 'ked ' + write(6,*) maxval(sp_tau), minval(sp_tau), 'sp_tau ' + pause + endif + +! + end subroutine ugwp_lsatdis_az1 +! + subroutine ugwp_limit_1d(ax, ay,eps, ked, levs) + use cires_ugwp_module, only : max_kdis, max_eps, max_axyz + implicit none + integer :: levs + real, dimension(levs) :: ax, ay,eps + real, dimension(levs+1) :: ked + real, parameter :: xtiny = 1.e-30 + where (abs(ax) > max_axyz ) ax = ax/abs(ax+xtiny)*max_axyz + where (abs(ay) > max_axyz ) ay = ay/abs(ay+xtiny)*max_axyz + where (abs(eps) > max_eps ) eps = eps/abs(eps+xtiny)*max_eps + where (ked > max_kdis ) ked = max_kdis + end subroutine ugwp_limit_1d diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 new file mode 100644 index 000000000..0d3cce194 --- /dev/null +++ b/physics/cires_vert_orodis.F90 @@ -0,0 +1,1018 @@ +! subroutine ugwp_drag_mtb +! subroutine ugwp_taub_oro +! subroutine ugwp_oro_lsatdis +! + subroutine ugwp_drag_mtb( iemax, nz, & + elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & + up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) + + use ugwp_common, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi + use ugwp_oro_init,only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver + + implicit none +!======================== +! several versions for drmtb => high froude mountain blocking +! version 1 => vay_2018 ; +! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 +! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 +!======================== + +! character(len=8) :: strver = 'vay_2018' +! real, parameter :: Fcrit_mtb = 0.7 + + integer, intent(in) :: nz + integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime + real , intent(out) :: taumtb + + integer , intent(out) :: idxzb + real, dimension(nz), intent(out) :: drmtb + + real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) + real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam + real, intent(in) :: zpbl + + real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid + real, dimension(nz+1), intent(in) :: zpi, pint +! + real, dimension(nz+1) :: zpi_zero + real, dimension(nz) :: zpm_zero + real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp + + real, dimension(nz) :: bn2, uds, umf, cosang, sinang + + integer :: k, klow, ktop, kpbl + real :: uhm, vhm, bn2hm, rhohm, & + mtb_fix, umag, bnmag, frd_src, & + zblk, who_iz_normal, rlm97, & + phiang, ang, pe, ek, & + cang, sang, ss2, cs2, zlen, dbtmp, & + hamp, bgamm, cgamm + +!================================================== +! +! elvp + hprime <=>elvp + nridge*hprime, ns =2 +! ns = sigfac +! tau_parel & tau_normal along major "axes" +! +! options to block the "flow", choices for [klow, ktop] +! +! 1-directional (normal) & 2-directional "blocking" +! +!================================================== +! no - blocking: drmtb(1:nz) = 0.0 +!================= + idxzb = -1 + drmtb(1:nz) = 0.0 + taumtb = 0.0 + klow = 2 + + ktop = iemax + hamp = nridge*hprime + +! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime + + mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp + + if (mtb_fix == 0.) then + print *, cdmb, sigma, hamp + print *, ' MTB == 0' + stop + endif + + if (strver == 'vay_2018') then + + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + + do k=1, nz-1 + if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then + ktop = k+1 !......simply k+1 next interface level + exit + endif + enddo +! print *, klow, ktop, ' klow-ktop ' + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s + if (bn2hm .le. 0.0) then + print *, ' unstable MF for MTB -RETURN ' + RETURN ! unstable PBL + endif + bnmag =sqrt(bn2hm) + + frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. + +! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' +! + if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking +! +! zblk > 0 +! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk +! + zblk = hamp*(1. - Fcrit_mtb/frd_src) + idxzb =1 + do k = 2, ktop + + if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then + idxzb = k + exit + endif + enddo +! + if (idxzb == 1) RETURN ! first surface level block is not "important" + + if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 +! +! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 +! + bgamm = 1.0 - 0.18*gam -0.04*gam*gam + cgamm = 0.48*gam +0.3*gam*gam + + do k = 1, idxzb-1 + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + + umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + + phiang = atan(vp(k)/umag) +! theta -90/90 + ang = theta - phiang + cang = cos(ang) ; sang = sin(ang) + + who_iz_normal = max(cang, gam*sang ) !gfs-2018 + + cs2 = cang* cang ; ss2 = 1.-cs2 + + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it +! + if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level +! + + who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS + + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + if (dbtmp < 0) dbtmp = 0.0 +! +! several approximation can be made to implement MTB-drag +! as a "nonlinear level dependent"-drag or "constant"-drag +! uds(k) == umag = const between the 1-layer and idxzb +! + + drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u + taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! +! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used +! with Umag-projections on A & B ellipse axes +! mtb_fix =0.25*cdmb*sigma/hprime, +! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. +! +!333 format(i4, 7(2x, F10.3)) +! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 + enddo +! + endif + endif ! strver=='vay_2018' +! +! +! + if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then + + print *, ' kdn_2005 with # of hills ' +! +! compute flow-blocking stress based on WRF 'gwdo2d' +! + endif +! +! + if (strver == 'gfs_2018') then + + ktop = iemax; klow = 2 + + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + if (bn2hm <= 0.0) RETURN ! unstable PBL +!--------------------------------------------- +! +!'gfs_2018' .... does not rely on Fr_crit +! and Fr-regimes +!----gfs17 for mtn ignores "averaging of the flow" +! for MTB-part it is only works with "angles" +! no projections on [uhm, vhm] -direction +! kpbl can be used for getting high values of iemax-hill +!----------------------------------------------------------- + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + do k=1, nz-1 + if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then + kpbl = k+1 + exit + endif + enddo + + do k = iemax, 1, -1 + + uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + phiang = atan(vp(k)/uds(k)) + ang = theta - phiang + cosang(k) = cos(ang) + sinang(k) = sin(ang) + + if (idxzb == 0) then + pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) + umf(k) = uds(k) * cosang(k) ! normal to main axis + ek = 0.5 * umf(k) * umf(k) +! +! --- dividing stream lime is found when pe =>exceeds ek first from the "top" +! + if (pe >= ek) idxzb = k + exit + endif + enddo + +! idxzb = min(kpbl, idxzb) +! +! +! +! last: mtb-drag +! + if (idxzb > 1) then + zblk = zpm(idxzb) + print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) + do k = idxzb-1, 1, -1 +! + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + cs2 = cosang(k)* cosang(k) + ss2 = 1.-cs2 + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it + + who_iz_normal = max(cosang(k), gam*sinang(k)) +! +! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) +! + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + + drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u +! + taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! + enddo + endif + endif ! strver=='gfs17' +! +! + end subroutine ugwp_drag_mtb +! +! +! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] +! +! + subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & + hprime , sigma, theta, oc, oa4, clx4, gamm, & + elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & + tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) +! + use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin + use cires_ugwp_module, only : frcrit, ricrit, linsat + use ugwp_oro_init, only : hpmax, cleff, frmax + use ugwp_oro_init, only : nwdir, mdir, fdir + use ugwp_oro_init, only : efmin, efmax , gmax, cg, ceofrc + use ugwp_oro_init, only : fcrit_sm, fcrit_gfs, frmin, frmax + use ugwp_oro_init, only : coro, nridge, odmin, odmax + use ugwp_oro_init, only : strver +! + use ugwp_oro_init, only : mkz2min, lzmax, zbr_pi +! --- +! +! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) +! approximate for drlee-momentum tendency +! --- + implicit none +! + integer, intent(in) :: levs, izb + real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero + integer, intent(out) :: kdswj, krefj, kotr + integer :: klwb + real, intent(in) :: kxw, fcor + real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp + +! + real, intent(in) :: oa4(4), clx4(4) + + real, dimension(levs), intent(in) :: up, vp, tp, qp, dp + real, dimension(levs+1), intent(in) :: zpi, pint + real, dimension(levs ), intent(in) :: zpm, pmid +! + real,dimension(levs), intent(out) :: drlee + real,dimension(levs+1), intent(out) :: tau_src +! + real, intent(out) :: tauogw, tautot, taulee + real :: taulin, tauhcr, taumtb + real, intent(out) :: xn, yn, umag, kxridge +! +! +! locals +! four possible versions to compute "taubase as a function of Fr-number" +! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' +! + real, dimension(levs+1) :: zpi_zero + + real :: oa, clx, odir, cl4p(4), clxp + + real :: uhm, vhm, bn2hm, rhohm, bnv + + real :: elvpMTB, wdir + real :: tem, efact, coefm, kxlinv, gfobnv + + real :: fr, frlin, frlin2, frlin3, frlocal, dfr + real :: betamax, betaf, frlwb, frmtb + integer :: klow, ktop, kph + + integer :: i, j, k, nwd, ind4, idir + + real :: sg_ridge, kx2, umd2 + real :: mkz, mkz2, zbr_mkz, mkzi + + real :: hamp ! clipped hprime*elvmax/elv_clip > hprime + real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) + real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves + real :: hcrit + real :: hblk ! blocking div-stream height + + real :: coef_h2, frnorm + + + real, dimension(levs) :: bn2 + real :: rho(levs) + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + real, dimension(levs+1) :: umd, phmkz + real :: c2f2, umag2, dzwidth, udir + real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp + real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms + real, dimension(levs+1) :: dtrans, deff + real :: pdtrans + logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 + logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum + ! between ZMTB => ZHILL +!----------------------------------------------------------------------------- +! +! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) +! ZMTB < ZOGW = ns*HPRIME < ELVP +! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB +! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new +! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW +! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB +! +!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] +! can be based on numerical runs like WRF-model +! for Frc < Fr< [Frc : 2.5-3 Frc] +! see suggestions proposed in SM-2000 and Eckermann et al. (2010) +!----------------------------------------------------------------------------- + tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 + krefj = 1 ; kotr = levs+1; kdswj = 1 + xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw + + dtrans = 0. ; deff =0. + klow = 2 + elvpMTB = elvp +! +! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB +! + if (izb > 0 ) then + klow = izb + elvpMTB = max(elvp - zpi(izb), 0.0) + endif + if (elvpMTB <=0 ) print *, ' blocked flow ' + if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX + + zpi_zero(:) = zpi(:) - zpi(1) + hblk = zpi_zero(klow) + + sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) + +! +! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp +! + sg_ridge = min(sg_ridge, hpmax) + +! print *, 'sg_ridge ', sg_ridge + + do k=1, levs + if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then + ktop = k+1 + exit + endif + enddo + + krefj = ktop ! the mountain top index for sg_ridge = ns*hprime + +! if ( izb > 0 .and. krefj .le. izb) then +! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' +! endif + +! +! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L +! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution +! + call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + call get_unit_vector(uhm, vhm, xn, yn, umag) + + if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment + bnv = sqrt(bn2hm) + hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer + hogw = hamp + hdsw = hamp + + + fr = bnv * hamp /umag + fr = min(fr, frmax) + kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx + kx2 = kxridge*kxridge + umag = max( umag, velmin) + c2f2 = fcor*fcor/kx2 + umag2 = umag*umag - c2f2 + + if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx + + mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" + ! and non-stationary waves coro, fcor for small umag + ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg + IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN +! +! case then no effects of wave-orography +! + krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 + tautot = 0. + tauogw = 0. + taulee = 0. + drlee = 0. ; tau_src(1:levs+1) = 0. + return + ENDIF +!========================================================================= +! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! make sure that SM_00 and KD_05 oro-characteristics can match each other +! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime +! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] +! alph-SM00 fraction of h2d contributed to hprime [0:1] +! +! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] +! delt-SM00 dw/up asymmetry -1 < delta < 1 +! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 +!.. +!A parametrization of low-level wave breaking which includes a dependence on +!the degree of 2-dimensionality of SG; it is active over a finite range of Fr +!========================================================================= + wdir = atan2(uhm,vhm) + pi + idir = mod( int(fdir*wdir),mdir) + 1 + + nwd = nwdir(idir) + ind4 = mod(nwd-1,4) + 1 + if (ind4 < 1 ) ind4 = 1 + if (ind4 > 4 ) ind4 = 4 + + oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) + clx = clx4(ind4) + cl4p(1) = clx4(2) + cl4p(2) = clx4(1) + cl4p(3) = clx4(4) + cl4p(4) = clx4(3) + clxp = cl4p(ind4) + + odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" + + odir = min(odmax, odir) + odir = max(odmin, odir) + + + if (strver == 'smc_2000' .or. strver == 'vay_2018') then +!========================================================================= +! +! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb +! taulin/tauogw taulee taumtb +! here tau_src(levs+1): approximate wave flux from surface to LLWB +! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) +!========================================================================= +! +! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 +! wave flux ~ rho_src*kx_src/mkz_src*wind_rms +! bn2, uhm, vhm, bn2hm, rhohm +! +! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN +! +! wave regimes +! + mkz = sqrt(mkz2) + frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb + frlin = fcrit_sm + frlin2 = 1.5*fcrit_sm + frlin3 = 3.0*fcrit_sm + + hcrit = fcrit_sm*umag/bnv + hogw = min(hamp, hcrit) + hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution + + coef_h2 = kxridge * rhohm * bnv * umag + + taulin = coef_h2 * hamp*hamp + tauhcr = coef_h2 * hcrit*hcrit + + IF (fr < frlin ) then + tauogw = taulin + taulee = 0.0 + taumtb = 0.0 + else if (fr .ge. frlin ) then + tauogw = tauhcr + taulin = coef_h2 * hamp*hamp + taumtb = tau_izb ! integrated form MTB +! +! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? +! + frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] + BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] + + if ( fr <= frlin2 ) then + Betaf= 2.*BetaMax*(frNorm-1.0) + taulee = (1. + Betaf )*taulin - tauhcr + else if ( (fr > frlin2).and.(fr <= frlin3))then + Betaf=-1.+ 1./frnorm/frnorm + & + (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) + taulee = (1. + Betaf )*taulin - tauhcr +!============== +! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) +! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) +! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) +! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) +! +!============== + else + taulee = 0.0 + hdsw = 0.0 + endif + ENDIF + + tautot = tauogw + taulee + taumtb*0. + + IF (taulee > 0.0 ) THEN + + hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge +! +! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves +! make "empirical" height above elvp that may represent DSW-wave breaking & trapping +! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge +! + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) ! kph marks the low-level of wave solutions + klwb = kph ! klwb above blocking marks wave-breaking + kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level + + if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) + + udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) + hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) + umd(krefj) = udir + + udir = max(ui(kph)*xn +vi(kph)*yn, velmin) + hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) + umd(kph) = udir + ! what we can put between k =[kph:krefj] + phmkz(:) = 0.0 ! + phmkz(kph-1) = fr ! initial Phase of the low-level wave +! +! now transfer tau_layer => tau_level assuming tau_layer = tau_level +! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT +! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 +! + loop_lwb_otr: do k=kph+1, krefj ! levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, dw2min) -c2f2 + + + if (umd2 <= 0.0) then +! +! critical layer +! + klwb = k + kotr = k + exit loop_lwb_otr + endif + + mkz2 = bn2i(k)/umd2 - kx2 + + if ( mkz2 >= mkz2min ) then +! +! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 +! at finest vertical resolution we can meet "abrupt" mkz +! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km +! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) +! + mkz = sqrt(mkz2) + hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) + udswz = hdswz *bn2i(k) +!=========================================================================================== +!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 +! +! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz +! by k = krefj tautot = tauogw(krefj) +!=========================================================================================== + if (do_klwb_phase) then + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then + klwb = min(k, krefj) + exit loop_lwb_otr + endif + endif + else ! mkz2 < mkz2min + kotr = k ! trapped/reflected waves / + exit loop_lwb_otr + endif + enddo loop_lwb_otr +! +! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee +! tau_trapped ??? +! + if (do_klwb_phase) then + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif +! +! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) +! more complicated is dissipative saturation pdtrans =/= constant +! + if (do_dtrans) then + do k=kph, krefj + tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) + drlee(k) = -tau_src(k)/rho(k) * pdtrans + enddo + endif + + + ENDIF !taulee > 0.0 + + + endif !strver +! + +!========================================================================= + if (strver == 'gfs_2018' .or. strver == 'kd_2005') then +!========================================================================= +! +! orowaves: OGW+DSW/Lee +! + efact = (oa + 2.0) ** (ceofrc*fr) + efact = min( max(efact,efmin), efmax ) + coefm = (1. + clx) ** (oa+1.) + + kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx + kxlinv = coefm * cleff + tem = fr * fr * oc + gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 +!========================================================================= +! source fluxes: taulin, taufrb +!========================================================================= + tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact + + coef_h2 = kxlinv *rhohm * bnv*umag + taulin = coef_h2 *hamp*hamp + hcrit = fcrit_gfs*umag/bnv + tauhcr = coef_h2 *hcrit*hcrit + + IF (fr <= fcrit_gfs) then + tauogw = taulin + tautot = taulin + taulee = 0. + drlee(:) = 0. + ELSE !fr > fcrit_gfs + tauogw = tauhcr + taulee = max(tautot - tauogw, 0.0) + if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) +! approximate drlee(k) between [izb, klwb] +! find klwb and decrease taulee(izb) => taulee(klwb) = 0. +! above izb tau + if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then + + mkz = sqrt(mkz2) + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) + phmkz(:) = 0.0 + klwb = max(izb, 1) + kotr = levs+1 + phmkz(kph-1) = fr ! initial Phase of the Lee-OGW + + loop_lwb_gfs18: do k=kph, levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, velmin*velmin) + mkz2 = bn2i(k)/umd2 - kx2 + if ( mkz2 > mkz2min ) then + mkz = sqrt(mkz2) + frlocal = max(hdsw*bvi(k)/umd(k), frlwb) + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k + else + kotr = k + exit loop_lwb_gfs18 + endif + enddo loop_lwb_gfs18 +! +! + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 + ENDIF !fr > fcrit_gfs + + + ENDIF !strbase='gfs2017' .or. strbase='kd_2005' + + +! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge +! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' +! + end subroutine ugwp_taub_oro +! +!-------------------------------------- +! +! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & +! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & +! xn, yn, umag, drtau, kdis_oro) + + subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & + kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + xn, yn, umag, drtau, kdis) + + use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav + use cires_ugwp_module, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 + use cires_ugwp_module, only : kvg, ktg, krad, kion + use ugwp_oro_init, only : coro , fcrit_sm , fcrit_sm2 + implicit none +! + integer, intent(in) :: krefj, levs + real , intent(in) :: tauogw, tautot, kxw + real , intent(in) :: fcor + + real , dimension(levs+1) :: tau_src + + real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm + real, dimension(levs+1), intent(in) :: zpi, pmid, pint + real , intent(in) :: xn, yn, umag + real , intent(in) :: kxridge + + + real, dimension(levs), intent(out) :: drtau, kdis +! +! locals +! + real :: uref, udir, uf2, ufd, uf2p + real, dimension(levs+1) :: tauz + real, dimension(levs) :: rho + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + + integer :: i, j, k, kcrit, kref + real :: kx2, kx2w, kxs + real :: mkzm, mkz, dkz, mkz2, ch, kzw3 + real :: wfdM, wfdT, wfiM, wfiT + real :: fdis, mkzi, keff_m, keff_t + real :: betadis, betam, betat, cdfm, cdft + real :: fsat, hsat, hsat2, kds , c2f2 + + drtau(1:levs) = 0.0 + kdis (1:levs) = 0.0 + + ch = coro + + kx2w = kxw*kxw + kx2 = kxridge*kxridge + if( kx2 < kx2w ) kx2 = kx2w + kxs = sqrt(kx2) + c2f2 = fcor*fcor/kx2 +! +! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) +! +! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) +!=============================================================================== +! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 +! rotational/non-hyrostatic effects are important only for high-res runs +! Udir = 0, Udir < 0 are not +! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz +! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) +! stochastic "tauogw'-setup+ sigma_tau ; +! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves +! target is to get "multiple"-saturation levels for OGWs +!=============================================================================== + tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode + ! sign of tauz > 0...and its attenuate with Z + k = krefj + uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves + uf2 = uref*uref - c2f2 + if (uf2 > 0) then + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2.gt.0) then + mkzm = sqrt(mkz2) + else + return ! wave reflection mkz2 <=0. + endif + else + return ! wave absorption uf2 <= 0. + endif +! +! upward solver for single "mode" with tauz(levs+1) =0. at the top +! + kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer + kcrit = levs + do k= krefj+1, levs +! +! 2D-wave propagation along reference-wind direction +! udir = 0 critical wind for coro =0 +! cdop = -uref .... upwind waves travel against MF +! + udir = ui(k)*xn +vi(k)*yn + uf2 = udir*udir - c2f2 + + + if (uf2 < dw2min .or. udir <= 0.0) then + kcrit =K + tauz(kcrit:levs) = 0. + exit ! vert-level loop + endif +! +! wave-based solution +! + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2 > 0) then + mkzm = sqrt(mkz2) +! +! do dissipative flux vs saturation: kvg, ktg, krad, kion +! + kzw3 = mkzm*mkz2 +! + keff_m = kvg(k)*mkz2 + kion(k) +! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol + keff_t = ktg(k)*mkz2 + krad(k) +! +! + uf2p = uf2 + 2.0*c2f2 + betadis = uf2/uf2p + betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw + betaT = 1.0- BetaM + +! +!imaginary frequencies of momentum and heat with "kds at (k-1) level" +! + wfiM = kds*mkz2 + keff_m + wfiT = kds*mkz2 + keff_t +! + cdfm = sqrt(uf2)*kxs + cdft = abs(udir)*kxs + wfdM = wfiM/cdfm *BetaM + wfdT = wfiT/Cdft *BetaT + mkzi = 2.0*mkzm*(wfdM+wfdT) + + fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) + tauz(k) = fdis + hsat2 = fcrit_sm2 * uf2 *bn2i(k) + fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) + if (fdis > fsat) then + tauz(k) = min(fsat, tauz(k-1)) +!================================================================= +! two definitions for eddy mixing of MF: +! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 +! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 +!================================================================= + kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) + kdis(k) = kds + endif + else + tauz(k:levs) = 0. ! wave is reflected above + kds = 0. + endif + enddo + + do k=krefj+1, kcrit + drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) + enddo +! +! + end subroutine ugwp_oro_lsatdis +! +! + subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & + utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common , only : rcpd2 + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none +! + integer :: im, levs + real(kind_phys), dimension(im, levs) :: u, v, zmid + real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl + real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: sgh = 30. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 +! + + do i=1, im + + zdec = max(n_tofd*sigflt(i), zpbl(i)) + zdec = min(ze_tofd, zdec) + rzdec = 1.0/zdec + sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) + + do k=1, levs + zmet = zmid(i,k) + if (zmet > ztop_tofd) cycle + ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) + umag = sqrt(ekin) + zarg = zmet*rzdec + zexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp + utofd(i,k) = -krf*u(i,k) + vtofd(i,k) = -krf*v(i,k) + epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re + krf_tofd(i,k) = krf + enddo + enddo +! + end subroutine ugwp_tofd +! +! + subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common , only : rcpd2 + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none + integer :: levs + real(kind_phys), dimension(levs) :: u, v, zmid + real(kind_phys) :: sigflt, elvmax, zpbl, zsurf + real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: sghmax = 5. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed 18 km + rzdec = 1.0/zdec + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + ekin = u(k)*u(k) + v(k)*v(k) + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf + enddo +! + end subroutine ugwp_tofd1d diff --git a/physics/cires_vert_wmsdis.F90 b/physics/cires_vert_wmsdis.F90 new file mode 100644 index 000000000..9e0bbf37c --- /dev/null +++ b/physics/cires_vert_wmsdis.F90 @@ -0,0 +1,425 @@ + subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & + fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & + kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) +! +! +! use para_taub, only : tau_ex + use ugwp_common, only : rcpd, grav, rgrav + implicit none +! + integer :: levs + integer :: nw, naz ! # - waves for each azimuth (naz) + integer :: ksrc ! source level + real :: kxw ! horizontal wn + real :: taub_lat ! lat-dep tau_bulk N/m2 +! + real, dimension(nw) :: ch, dch, taub_spect + real, dimension(naz) :: xaz, yaz + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint + real, dimension(levs ) :: dp, rho, pmid, zmid + real :: fcor, c2f2 + real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol + +! output/locals + real, dimension(levs ) :: ax, ay, eps + real, dimension(levs+1) :: ked , tau1 + real, dimension(levs+1 ) :: uaz + + real, dimension(levs, naz ) :: epsd + real, dimension(levs+1, naz ) :: atau, kedd + + real, dimension(levs+1 ) :: taux, tauy, bnrho + real, dimension(levs ) :: dzirho , dzpi + +! + integer :: iaz, k , inc + real, parameter :: gcstar=1.0 + integer , parameter :: nslope=1 + real :: spnorm ! source level normalization factor for the Broad Spectra + real :: bnrhos ! sum(taub_spect*dc) = spnorm taub_sect_norm = taub_spect/spnorm +! + atau=0.0 ; epsd=0.0 ; kedd=0.0 + bnrhos = bvi(ksrc)/rhoi(ksrc) + do k=1,levs + dzpi(k) = zint(k+1)-zint(k) + dzirho(k) = 1.0 / (rho(k)*dzpi(k)) ! grav/abs(dp(k)) still hydrostatic "ugwp" + bnrho(k) = (rhoi(k)/bvi(k)) !*bnrhos * gcstar ! gcstar=1.0 and bnrho(k=ksrc) =1. + enddo + k = levs+1 + bnrho(k) = (rhoi(k)/bvi(k))*bnrhos +! +! re-define ch, dch, taub_spect, this portion can be moved to "ugwp_init" +! +! +! + call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) + + +! print *, ' after FVS93_ugwp ', nw, maxval(ch), minval(ch) +! +! do normaalization for the spectral element of the saturated flux +! + bnrho = bnrho *spnorm + +! print * +! do inc=1, nw +! write(6,221) inc, ch(INC),taub_lat*taub_spect(inc), spnorm, dch(inc) +!221 FORMAT( i6, 2x, F8.2, 3(2x, E10.3)) +! enddo +! pause + + loop_iaz: do iaz =1, naz + + do k=1,levs+1 + uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) + enddo +! +! +! multi-wave broad spectrum of FVS-93 with ~scheme of WMS-IFS 2010 +! +! print *, ' iaz before ugwp_wmsdis_az1 ', iaz +! + + call ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_spect, taub_lat, & + spnorm, fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, bnrho, dzirho, dzpi, & + kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) + +! print *, ' iaz after ugwp_wmsdis_az1 ', iaz + +! + enddo loop_iaz ! azimuth of gw propagation directions +! +! sum over azimuth and project atau(z, iza) =>(taux and tauy) +! for scalars for "wave-drag vector" +! + eps =0. ; ked =0. + do k=ksrc, levs + eps(k) = sum(epsd(k,:))*rcpd + enddo + + do k=ksrc, levs+1 + taux(k) = sum( atau(k,:)*xaz(:)) + tauy(k) = sum( atau(k,:)*yaz(:)) + ked(k) = sum( kedd(k,:)) + enddo +! + tau1(ksrc:levs) = taux(ksrc:levs) + tau1(1:ksrc-1) = tau1(ksrc) + +! end solver: gw_azimuth_solver_ls81 +! sign ax in rho*du/dt = -d(rho*tau)/dz +! [(k) - (k+1)] +! du/dt = ax = -1/rho*d( tau) /dz +! + ax =0. ; ay = 0. + + do k=ksrc, levs + ax(k) = dzirho(k)*(taux(k)-taux(k+1)) + ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) + enddo + call ugwp_limit_1d(ax, ay, eps, ked, levs) + + return + end subroutine ugwp_wmsdis_naz + + +! ======================================================================= + subroutine ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_sp, tau_bulk, & + spnorm, fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, bnrho, & + dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) +! +! use para_taub, only : tau_ex, xlatdeg !for exchange src-tau +! + use cires_ugwp_module, only : f_coriol, f_nonhyd, f_kds, linsat + use cires_ugwp_module, only : ipr_ktgw, ipr_spgw, ipr_turb, ipr_mol + use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim +! ======================================================================= + integer :: levs, ksrc, nw + real :: fcor, c2f2, kxw +! + real, dimension(nw) :: taub_sp, ch, dch + real :: tau_bulk, spnorm + real, dimension(levs) :: zm, rho, dzirho, dzpi + real, dimension(levs+1) :: zi, um, tm, bn2, bn, rhoi, bnrho + real, dimension(levs+1) :: kvg, ktg, krad, kion, kmol + real, dimension(levs+1) :: ked, tau + real, dimension(levs ) :: eps +! +!locals + integer :: k, inc + real, dimension(levs+1) :: umi + real :: zcin, zci_min, ztmp, zcinc + real :: zcimin=0.5 ! crit-level precision, 0.5 and start of Ch_MIN + real, parameter :: Keff = 0.2 + + real, dimension(nw) :: zflux ! + real, dimension(nw) :: wzact, zacc ! =1 ..crit level change it + + real, dimension(levs) :: zcrt ! + real, dimension(nw, levs) :: zflux_z, zact + + real :: zdelp, kxw2 + real :: vu_eff, vu_lin, v_kzw, v_cdp, v_wdp, v_kzi + real :: dfsat, fdis, fsat, fmode, expdis + real :: vc_zflx_mode, vm_zflx_mode + real :: tau_g5 +! ======================================================================= +!eps, ked, tau + + eps (:) =0; ked = 0.0 ; + kxw2 = kxw*kxw +! + zcrt(1:levs) = 0.0 + umi(1:levs+1) = um +! umi(1:levs+1) = um(1:levs+1) -um(ksrc) + + zci_min = zcimin + +! CALL slat_geos5(1, xlatdeg(1), tau_g5) +! tau_bulk = tau_g5 !tau_bulk*0.75 !3.75e-2 +! + zflux(:) = taub_sp(:)*tau_bulk ! includes tau_bulk(x,y) and spectral normalization + + zflux_z(1:nw,ksrc)=zflux(:) + + tau(1:levs+1) = tau_bulk ! constant flux for all layers k0.0 ) then +! ztmp = sum( ch(:)*zacc(:)*zflux(:)*dch(:) ) +! zcrt(k)=ztmp/tau(k) +! else +! zcrt( k )=zcrt(k-1) +! endif +! --------------------------------------------------------- +! do saturation (eq. (26) and (27) of scinocca 2003) +! + add molecular/eddy dissipation od gw-spectra vay-2015 +! for each mode & direction +! x by exp(-mi*zdelp) x introduce ....... mi(nw) +! +! mode-loop + add molecular/eddy dissipation od gw-spectra vay-2015 +! + do inc=1,nw + if (zact(inc,k) == 0.0) then + zflux(inc) = 0.0 + zflux_z(inc,k) = zflux(inc) + else + vu_eff = kvg(k) ! + ktg (k) !* ipr_ktgw + vu_lin = kion(k) ! + krad(k) !* ipr_ktgw + vu_eff = 2.e-5*exp(zi(k)/7000.)+.01 + zcin= ch(inc) + +!======================================================================= +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +! define kxw = +!======================================================================= + v_cdp = zcin-umi(k) + v_wdp = kxw*v_cdp + if (v_wdp.gt.0) then + v_kzw = bn(k)/v_cdp !can be non-hydrostatic + v_kzi = abs(( v_kzw*v_kzw*vu_eff + vu_lin) /v_wdp*v_kzw) + expdis = exp(-2.*v_kzi*dzpi(k) ) + else + v_kzi = 0. + expdis = 1.0 + endif + fmode = zflux(inc) + fdis = fmode*expdis ! only dissipation/crit_lev degrades it +!------------------------ +! includes rho/bn /(rhos/bns) *spnorm +!------------------------ + fsat = bnrho(k)* v_cdp*v_cdp /zcin ! expression for saturated flux + ! zfluxs=gcstar*zfct( k)*(zcin-zui( k ))**2/zcin +! flux_tot - sat.flux +! + dfsat= fdis-fsat + if( dfsat > 0.0 ) then +! put sat-n limit + zflux(inc) = fsat + else +! assign dis-ve flux + zflux(inc) =fdis + endif + zflux_z(inc,k)=zflux(inc) + + if (zflux_z(inc,k) > zflux_z(inc,k-1) ) zflux_z(inc,k) = zflux_z(inc,k-1) + + endif + + enddo +! +! integrate over spectral modes zpu(y, z, azimuth) zact( inc, )*zflux( inc, )*[d("zcinc")] +! + tau(k) = sum( zflux_z(:,k)*dch(:)) +!------------------------------------------------------------------------------ +! define expressions for eps-heat + Ked, needs more work for the broad spectra +! formulation especially for Ked +! after defining Ked .....GW-eddy cooling needs to be added +! for now "only" heating here +!============================================================================== + eps(k) =0. + do inc=1, nw + if (zact(inc,k) == 0.0) cycle ! dc-integration + dtau/dz + vc_zflx_mode = zflux(inc) + + zdelp= abs(ch(inc)-umi(k)) * dch(inc) /dzpi(k) + vm_zflx_mode=zflux_z(inc,k-1) + eps(k) =eps( k ) + (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 + + + enddo !inc=1, nw + ked(k) = Keff*eps(k)/bn2(k) +! +! -------------- +! + enddo ! end k do-loop vertical loop do k=ksrc+1, levs + +!top lid + k =levs+1 + ked(k) = ked(k-1) +! eps(k) = eps(k-1) + tau(k) =tau(k-1)*0.933 + +! from surface to ksrc-1 +! tau(1:ksrc) = tau(ksrc) + ked(1:ksrc) = 0. + eps( 1:ksrc) = 0. + +! +! output: eps, ked, tau for given azimuth +! + end subroutine ugwp_wmsdis_az1 +! +! + subroutine FVS93_ugwps(nw, ch, dch, taub_sp, spnorm, nslope, bn2, bn, bnrhos) + implicit none + integer :: nw, nslope + real :: bn2, bn, bnrhos +!! real :: taub_lat ! bulk - lat-dep momentum flux + real, dimension (nw) :: ch, dch, taub_sp +! locals + integer :: i, inc + real, parameter :: zcimin = 0.5, zcimax = 95.0, zgam =1./4. + real, parameter :: zms = 6.28e-3/2. ! mstar Lz ~ 2km + real :: zxran, zxmax, zxmin, zx1, zx2, zdx, ztx, rch + real :: bn3, bn4, zcin, tn4, tn3, tn2, cstar + real :: spnorm ! needs to be passed for saturation flux norm-n + real :: tau_bulk +!-------------------------------------------------------------------- +! +! transforms ch -uniform => 1/ch and back to non-uniform ch, dch +! +!------------------------------------------------------------------- +! note that this is expresed in terms of the intrinsic ch or vertical wn=N/cd +! at launch cd=ch-um(ksrc), the transformation is identical for all +! levels, azimuths and horizontal pixels +! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform +! + zxmax=1.0 /zcimin + zxmin=1.0 /zcimax + zxran=zxmax-zxmin + zdx=zxran/float(nw-1) ! d_kz or d_mi +! +! + zx1=zxran/(exp(zxran/zgam)-1.0 ) !zgam =1./4. + zx2=zxmin-zx1 +! +! add idl computations for zci =1/zx +! x = 1/c stretching transform to look at final ch(i), dch(i) +! + + do i=1, nw + ztx=float(i-1)*zdx+zxmin + rch=zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 + ch(i)=1.0 /rch !eq. 28 of scinocca 2003 + dch(i)=ch(i)*ch(i)*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 + enddo +! +! nslope-dependent flux taub_spect(nw) momentum flux spectral density +! need to check math....expressions +! eq. (25) of scinocca 2003 with u-uo=0 it is identical to all azimuths +! +! + cstar=bn/zms + bn4=bn2*bn2 ! four times + bn3=bn2*bn + if(nslope==1) then +! s=1 case + do inc=1, nw + zcin=ch(inc) + tn4=(zms*zcin)**4 + taub_sp(inc) =bnrhos * zcin*bn4/(bn4+tn4) + enddo +! + elseif(nslope==2) then +! s=2 case + do inc=1, nw + zcin=ch(inc) + tn4=(zms*zcin)**4 + taub_sp(inc)= bnrhos*zcin*bn4/(bn4+tn4*zcin/cstar) + enddo +! + elseif(nslope==-1) then +! s=-1 case + do inc=1, nw + zcin=ch(inc) + tn2=(zms*zcin)**2 + taub_sp(inc)=bnrhos*zcin*bn2/(bn2+tn2) + enddo +! s=0 case + elseif(nslope==0) then + + do inc=1, nw + zcin=ch(inc) + tn3=(zms*zcin)**3 + taub_sp(inc)=bnrhos*zcin*bn3/(bn3+tn3) + enddo + endif ! for n-slopes +!============================================= +! normalize launch momentum flux +! ------------------------------------ +! (rho x f^h = rho_o x f_p^total) integrate (zflux x dx) + + tau_bulk= sum(taub_sp(:)*dch(:)) + spnorm= 1./tau_bulk + + do inc=1, nw + taub_sp(inc)=spnorm*taub_sp(inc) + enddo + + end subroutine FVS93_ugwps + diff --git a/physics/docs/pdftxt/CPT_adv_suite.txt b/physics/docs/pdftxt/CPT_adv_suite.txt index 7617d9df3..132d8bd11 100644 --- a/physics/docs/pdftxt/CPT_adv_suite.txt +++ b/physics/docs/pdftxt/CPT_adv_suite.txt @@ -82,7 +82,7 @@ The advanced csawmg physics suite uses the parameterizations in the following or GFS_PBL_generic_pre hedmf GFS_PBL_generic_post - gwdps_pre + GFS_GWD_generic_pre gwdps gwdps_post rayleigh_damp diff --git a/physics/docs/pdftxt/GFSv14_suite.txt b/physics/docs/pdftxt/GFSv14_suite.txt index 25e03e7fd..23f611a25 100644 --- a/physics/docs/pdftxt/GFSv14_suite.txt +++ b/physics/docs/pdftxt/GFSv14_suite.txt @@ -82,7 +82,7 @@ The GFS v14 suite uses the parameterizations in the following order, as defined GFS_PBL_generic_pre hedmf GFS_PBL_generic_post - gwdps_pre + GFS_GWD_generic_pre gwdps gwdps_post rayleigh_damp diff --git a/physics/docs/pdftxt/GFSv15_suite.txt b/physics/docs/pdftxt/GFSv15_suite.txt index 82545bbff..6b5fddcf8 100644 --- a/physics/docs/pdftxt/GFSv15_suite.txt +++ b/physics/docs/pdftxt/GFSv15_suite.txt @@ -92,7 +92,7 @@ The GFS v15 suite uses the parameterizations in the following order, as defined GFS_PBL_generic_pre hedmf GFS_PBL_generic_post - gwdps_pre + GFS_GWD_generic_pre gwdps gwdps_post rayleigh_damp diff --git a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt index e844f0206..56a1f97f5 100644 --- a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt +++ b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt @@ -83,7 +83,7 @@ The GFS v15plus suite uses the parameterizations in the following order, as defi GFS_PBL_generic_pre satmedmfvdif GFS_PBL_generic_post - gwdps_pre + GFS_GWD_generic_pre gwdps gwdps_post rayleigh_damp diff --git a/physics/docs/pdftxt/GSD_adv_suite.txt b/physics/docs/pdftxt/GSD_adv_suite.txt index 0db91ede1..995297a08 100644 --- a/physics/docs/pdftxt/GSD_adv_suite.txt +++ b/physics/docs/pdftxt/GSD_adv_suite.txt @@ -95,7 +95,7 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order sfc_diag_post GFS_surface_generic_post mynnedmf_wrapper - gwdps_pre + GFS_GWD_generic_pre gwdps gwdps_post rayleigh_damp diff --git a/physics/gwdps.f b/physics/gwdps.f index d98573dcc..f2f5f218f 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -2,145 +2,6 @@ !! This file is the parameterization of orographic gravity wave !! drag and mountain blocking. -!> This module contains the CCPP-compliant orographic gravity wave -!! drag pre interstitial codes. - module gwdps_pre - - contains - -!> \section arg_table_gwdps_pre_init Argument Table -!! - subroutine gwdps_pre_init() - end subroutine gwdps_pre_init - -!! \section arg_table_gwdps_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | -!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | -!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | -!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | -!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | -!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | -!! | ldiag3d | flag_diagnostics_3D | flag for 3d diagnostic fields | flag | 0 | logical | | in | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | in | F | -!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | -!! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - subroutine gwdps_pre_run( & - & im, levs, nmtvr, mntvar, & - & hprime, oc, oa4, clx, theta, & - & sigma, gamma, elvmax, lssav, ldiag3d, & - & dtdt, dt3dt, dtf, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs, nmtvr - real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) - - real(kind=kind_phys), intent(out) :: & - & hprime(im), oc(im), oa4(im,4), clx(im,4), & - & theta(im), sigma(im), gamma(im), elvmax(im) & - - logical, intent(in) :: lssav, ldiag3d - real(kind=kind_phys), intent(in) :: dtdt(im,levs) - ! dt3dt only allocated only if ldiag3d is .true. - real(kind=kind_phys), intent(inout) :: dt3dt(:,:) - real(kind=kind_phys), intent(in) :: dtf - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (nmtvr == 14) then ! current operational - as of 2014 - hprime(:) = mntvar(:,1) - oc(:) = mntvar(:,2) - oa4(:,1) = mntvar(:,3) - oa4(:,2) = mntvar(:,4) - oa4(:,3) = mntvar(:,5) - oa4(:,4) = mntvar(:,6) - clx(:,1) = mntvar(:,7) - clx(:,2) = mntvar(:,8) - clx(:,3) = mntvar(:,9) - clx(:,4) = mntvar(:,10) - theta(:) = mntvar(:,11) - gamma(:) = mntvar(:,12) - sigma(:) = mntvar(:,13) - elvmax(:) = mntvar(:,14) - elseif (nmtvr == 10) then - hprime(:) = mntvar(:,1) - oc(:) = mntvar(:,2) - oa4(:,1) = mntvar(:,3) - oa4(:,2) = mntvar(:,4) - oa4(:,3) = mntvar(:,5) - oa4(:,4) = mntvar(:,6) - clx(:,1) = mntvar(:,7) - clx(:,2) = mntvar(:,8) - clx(:,3) = mntvar(:,9) - clx(:,4) = mntvar(:,10) - elseif (nmtvr == 6) then - hprime(:) = mntvar(:,1) - oc(:) = mntvar(:,2) - oa4(:,1) = mntvar(:,3) - oa4(:,2) = mntvar(:,4) - oa4(:,3) = mntvar(:,5) - oa4(:,4) = mntvar(:,6) - clx(:,1) = 0.0 - clx(:,2) = 0.0 - clx(:,3) = 0.0 - clx(:,4) = 0.0 - else - hprime = 0 - oc = 0 - oa4 = 0 - clx = 0 - theta = 0 - gamma = 0 - sigma = 0 - elvmax = 0 - endif ! end if_nmtvr - - if (lssav) then - if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf - enddo - enddo - endif - endif - - end subroutine gwdps_pre_run -!> @} - -! \ingroup GFS_ogwd -! \brief Brief description of the subroutine -! -!> \section arg_table_gwdps_pre_finalize Argument Table -!! - subroutine gwdps_pre_finalize() - end subroutine gwdps_pre_finalize - - end module gwdps_pre - !> This module contains the CCPP-compliant orographic gravity wave dray scheme. module gwdps diff --git a/physics/ugwp_driver_v0.f b/physics/ugwp_driver_v0.f new file mode 100644 index 000000000..a3ca5f96d --- /dev/null +++ b/physics/ugwp_driver_v0.f @@ -0,0 +1,2008 @@ +!!23456 + module sso_coorde +! +! specific to COORDE-2019 project OGW switches/sensitivity +! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) +! pgd4=4 (4 timse taub, control pgwd=1) +! + use machine, only: kind_phys + real(kind=kind_phys),parameter :: pgwd = 1._kind_phys + real(kind=kind_phys),parameter :: pgwd4 = 1._kind_phys + end module sso_coorde +! +! + subroutine cires_ugwp_driver_v0(me, master, + & im, levs, nmtvr, dtp, kdt, imx,do_tofd, + & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, + & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, + & phii, phil, del, oro_stat, sgh30, kpbl, + & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, + & tau_tofd, tau_mtb, tau_ogw, tau_ngw, + & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb ) +!----------------------------------------------------------- +! Part 1 "old-revised" gfs-gwdps_v0 +! Part 2 non-stationary multi-wave GWs FV3GFS-v0 +! Part 3 Dissipative version of UGWP-tendency application +! (similar to WAM-2017) +!----------------------------------------------------------- + use machine, only: kind_phys +! use physcons, only: con_cp, con_fvirt, con_g, con_rd, +! & con_rv, con_rerth, con_pi + + use ugwp_wmsdis_init, only : tamp_mpa + use sso_coorde, only : pgwd, pgwd4 + implicit none +!input + + integer, intent(in) :: me, master + integer, intent(in) :: im, levs, nmtvr, kdt, imx + + real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(2) + logical :: do_tofd + integer, intent(in) :: kpbl(im) + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd + &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area + + real(kind=kind_phys), intent(in), dimension(im,levs) :: ugrs + &, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, del + + real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) +!out + real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt + &, gw_dTdt, gw_kdis + +!-----locals + diagnostics output + + real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt + &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt + + real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg + + real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, + & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw + &, du3dt_tms +! locals + integer :: i, j, k, ix +! +! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax +! + real(kind=kind_phys), dimension(im) :: hprime, + & oc, theta, sigma, gamm, elvmax + real(kind=kind_phys), dimension(im, 4) :: clx, oa4 +! +! switches that activate impact of OGWs and NGWs along with eddy diffusion +! + real(kind=kind_phys), parameter :: pogw=1.0, pngw=1.0, pked=1.0 + &, ompked=1.0-pked +! +! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) +! + if (me == master .and. kdt < 2) then + print * + write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr + write(6,*) ' COORDE EXPER pogw = ' , pogw + write(6,*) ' COORDE EXPER pgwd = ' , pgwd + write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 + print * + endif + + +! print *, ' NMTVR in driver ', nmtvr + do i=1,im + hprime(i) = oro_stat(i,1) + oc(i) = oro_stat(i,2) + oa4(i,1) = oro_stat(i,3) + oa4(i,2) = oro_stat(i,4) + oa4(i,3) = oro_stat(i,5) + oa4(i,4) = oro_stat(i,6) + clx(i,1) = oro_stat(i,7) + clx(i,2) = oro_stat(i,8) + clx(i,3) = oro_stat(i,9) + clx(i,4) = oro_stat(i,10) + theta(i) = oro_stat(i,11) + gamm(i) = oro_stat(i,12) + sigma(i) = oro_stat(i,13) + elvmax(i) = oro_stat(i,14) + + zlwb(i) = 0. + enddo +! +! 1) ORO stationary GWs +! +! pdvdt(:,:) = 0. ; pdudt(:,:) = 0. +! pkdis(:,:) = 0. ; pdtdt(:,:) = 0. +! zlwb(:) = 0. + + CALL GWDPS_V0(IM, levs, imx, do_tofd, + & Pdvdt, Pdudt, Pdtdt, Pkdis, + & ugrs, vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, + & prslk, phii, phil, DTP,KDT, + & sgh30, HPRIME,OC,OA4, CLX, THETA,SIGMA,GAMM,ELVMAX, + & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, + & cdmbgwd, me, master, rdxzb, + & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, + & du3dt_mtb, du3dt_ogw, du3dt_tms) +! +! +! non-stationary GW-scheme with GMAO/MERRA GW-forcing +! + if (me == master .and. kdt < 2) then + print * + write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' + print * + endif +!-------- +! GMAO GEOS-5/MERRA GW-forcing lat-dep +!-------- + call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) + +! call slat_geos5(im, xlatd, tau_ngw) +! +! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing +! + call fv3_ugwp_solv2_v0(im, levs, dtp, + & tgrs, ugrs, vgrs, qgrs, prsl, prsi, phil, xlatd, + & sinlat, coslat, gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, + & tau_ngw, me, master, kdt ) + + if (me == master .and. kdt < 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' + write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + endif + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) + enddo + enddo + 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_v0(im, levs, dtp, + & tgrs, ugrs, vgrs, qgrs, del, + & prsl, prsi, phil, prslk, + & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, + & ed_dudt, ed_dvdt, ed_dTdt, + & me, master, kdt ) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = gw_dtdt(i,k)*ompked + ed_dtdt(i,k)*pked + gw_dvdt(i,k) = gw_dvdt(i,k)*ompked + ed_dvdt(i,k)*pked + gw_dudt(i,k) = gw_dudt(i,k)*ompked + ed_dudt(i,k)*pked + enddo + enddo + + end subroutine cires_ugwp_driver_v0 +! +!===================================================================== +! +!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 +! +!===================================================================== + SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, + & Pdvdt, Pdudt, Pdtdt, Pkdis, U1,V1,T1,Q1,KPBL, + & 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, + & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, + & dudt_mtb, dudt_ogw, dudt_tms) +!---------------------------------------- +! ugwp_v0 +! +! modified/revised version of gwdps.f (with bug fixes, tofd, appropriate +! computation of kref for OGW + COORDE diagnostics +! all constants/parameters inside cires_ugwp_initialize.F90 +!---------------------------------------- + + USE MACHINE , ONLY : kind_phys + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + &, pi, rad_to_deg, deg_to_rad, pi2 + &, rdi, gor, grcp, gocp, fv, gr2 + &, bnv2min, dw2min, velmin, arad + + use ugwp_oro_init, only : rimin, ric, efmin, efmax + &, hpmax, hpmin, sigfaci => sigfac + &, dpmin, minwnd, hminmt, hncrit + &, RLOLEV, GMAX, VELEPS, FACTOP + &, FRC, CE, CEOFRC, frmax, CG + &, FDIR, MDIR, NWDIR + &, cdmb, cleff, fcrit_gfs, fcrit_mtb + &, n_tofd, ze_tofd, ztop_tofd + + use cires_ugwp_module, only : kxw, max_kdis, max_axyz + use sso_coorde, only : pgwd, pgwd4 +!---------------------------------------- + implicit none + character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' + integer, intent(in) :: im, levs, imx, kdt + integer, intent(in) :: me, master + logical, intent(in) :: do_tofd + real(kind=kind_phys), parameter :: sigfac =3, sigfacS = 0.5 + real(kind=kind_phys) :: ztopH,zlowH,ph_blk, dz_blk + 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), dimension(im,levs) :: + & u1, v1, t1, q1, + & del, prsl, prslk, phil + real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi, phii + real(kind=kind_phys), intent(in) ::xlatd(im),sinlat(im),coslat(im) + real(kind=kind_phys), intent(in) :: sparea(im) + + real(kind=kind_phys), intent(in) :: OC(IM), OA4(im,4), CLX4(im,4) + real(kind=kind_phys), intent(in) :: HPRIME(IM), sgh30(IM) + 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) + +!output -phys-tend + real(kind=kind_phys),dimension(im,levs),intent(out) :: + & Pdvdt, Pdudt, Pkdis, Pdtdt +! output - diag-coorde + &, dudt_mtb, dudt_ogw, dudt_tms +! + real(kind=kind_phys),dimension(im) :: RDXZB, zmtb, zogw + &, tau_ogw, tau_mtb, tau_tofd + &, dusfc, dvsfc + +! +! locals +! mean flow + real(kind=kind_phys) :: RI_N(IM,levs), BNV2(IM,levs), RO(IM,levs) + real(kind=kind_phys) :: VTK(IM,levs),VTJ(IM,levs),VELCO(IM,levs) +!mtb + real(kind=kind_phys) :: OA(IM), CLX(IM) , elvmax(im) + real(kind=kind_phys) :: wk(IM) + real(kind=kind_phys), dimension(im) :: PE, EK, UP + + real(kind=kind_phys) :: DB(IM,levs),ANG(IM,levs),UDS(IM, levs) + 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 + real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1 + &, epstofd1, krf_tofd1 + &, up1, vp1, zpm + real(kind=kind_phys) :: zsurf + real(kind=kind_phys),dimension(im, levs) :: axtms, aytms +! +! OGW +! + LOGICAL ICRILV(IM) +! + real(kind=kind_phys) :: XN(IM), YN(IM), UBAR(IM), + & VBAR(IM), ULOW(IM), + & ROLL(IM), bnv2bar(im), SCOR(IM), + & DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) +! + real(kind=kind_phys) :: TAUP(IM,levs+1), TAUD(IM,levs) + real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis + + integer :: kref(IM), idxzb(im), ipt(im), k_mtb,k_zlow + integer :: kreflm(IM), iwklm(im), iwk(im), izlow(im) + integer :: ktrial, klevm1 +! +!check what we need +! + real(kind=kind_phys) :: bnv, fr, ri_gw , + & brvf, tem, tem1, tem2, temc, temv, + & ti, rdz, dw2, shr2, bvf2, + & rdelks, efact, coefm, gfobnv, + & scork, rscor, hd, fro, sira, + & dtaux, dtauy, pkp1log, pklog + + integer :: km, kmm1, kmm2, lcap, lcapp1 + &, npt, kbps, kbpsp1,kbpsm1 + &, kmps, idir, nwd, klcap, kp1, kmpbl, kmll +!--------------------------------------------------------------------- +! # 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 +!--------------------------------------------------------------------- + real(kind=kind_phys) :: gammin = 0.00999999 + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax + real(kind=kind_phys), parameter :: nhilmax = 25. + real(kind=kind_phys), parameter :: sso_min = 3000. + real(kind=kind_phys) :: xlingfs + real(kind=kind_phys) :: arhills(im) + logical, parameter :: do_adjoro = .true. +! + integer :: i, j, k + real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + &, sigmin, dxres,sigres,hdxres + &, cdmb4, mtbridge + &, kxridge, inv_b2eff, zw1, zw2 + &, belps, aelps, nhills, selps +! + rcpdt = 1.0 / (cpd*dtp) + grav2 = grav + grav +! +! mtb-blocking sigma_min and dxres => cires_initialize +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + + dxres = pi2*arad/float(IMX) + hdxres = 0.5*dxres + shilmin = sgrmin/nhilmax + + gammin = min(sso_min/dsmax, 1.) + + sigmin = 2.*hpmin/dsmax !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(:) = 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 + enddo + + 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 + 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 + + ipt(:) = 0 + npt = 0 + sigma = vsigma + gamma = vgamma + do i = 1,im + if ( (elvmaxd(i) >= hminmt) + & .and. (gamma(i) >= gammin) + & .and. (hprime(i) >= hpmin) ) then + + npt = npt + 1 + ipt(npt) = i + arhills(i) = 1.0 +! + if (gamma(i) < gammin) gamma(i) = gammin + 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 .and. do_adjoro) 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 = sparea(i)/selps + if (nhills > nhilmax) nhills = nhilmax + 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) + + 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 + + + do i=1,npt + iwklm(i) = 2 + IDXZB(i) = 0 + kreflm(i) = 0 + enddo + + do k=1,levs + do i=1,im + db(i,k) = 0.0 + ang(i,k) = 0.0 + uds(i,k) = 0.0 + enddo + enddo + + km = levs + KMM1 = levs- 1 ; KMM2 = levs - 2 ; KMLL = kmm1 + LCAP = levs ; LCAPP1 = LCAP + 1 + + DO I = 1, npt + j = ipt(i) + ELVMAX(J) = min (ELVMAXd(J)*0. + sigfac * hprime(j), hncrit) + ENDDO +! + izlow(:) =1 ! surface-level + DO K = 1, levs-1 + DO I = 1, npt + j = ipt(i) + ztopH = sigfac * hprime(j) + zlowH = sigfacs* hprime(j) + pkp1log = phil(j,k+1) * rgrav + pklog = phil(j,k) * rgrav +! if (( ELVMAX(j) <= pkp1log) .and. (ELVMAX(j).ge.pklog) ) +! & iwklm(I) = MAX(iwklm(I), k+1 ) + if (( ztopH <= pkp1log) .and. (zTOPH >= pklog) ) + & iwklm(I) = MAX(iwklm(I), k+1 ) +! + if (zlowH <= pkp1log .and. zlowH >= pklog) + & izlow(I) = MAX(izlow(I),k) + ENDDO + ENDDO +! + DO K = 1,levs + 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,levs-1 + DO I =1,npt + J = ipt(i) + RDZ = grav / (phil(j,k+1) - phil(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 =>phil(j,k)/g < sigfac * hprime(j) < phil(j,k+1)/g +! + 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=( PHII(J,K+1) - PHII(J,K) ) *rgrav + PE(I) = PE(I) + BNV2(I,K) * + & ( ELVMAX(J) - phil(J,K)*rgrav ) * 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) = PHIL(J, K)*rgrav + 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 = phil(j,2)*rgrav + if (Fr > fcrit_gfs .and. zw1 > zw2 ) then + do k=2, levs-1 + pkp1log = phil(j,k+1) * rgrav + pklog = phil(j,k) * rgrav + if (zw1 <= pkp1log .and. zw1 >= pklog) exit + enddo + IDXZB(I) = K + zmtb (J) = PHIL(J, K)*rgrav + else + zmtb (J) = 0. + IDXZB(I) = 0 + endif +788 continue + ENDDO + +! +! --- The drag for mtn blocked flow +! + cdmb4 = 0.25*cdmb + DO I = 1, npt + J = ipt(i) +! + 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( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / + & ( PHIL(J,K ) + Grav * hprime(J) ) ) + + COSANG2 = cos(ANG(I,K))*cos(ANG(I,K)) + 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 MF +! (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-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 = levs + 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) <= idxzb(i)) kref(i) = idxzb(i) + 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, levs-1 + 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-OGWave"-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 from AS of Phillips et al. (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 *pgwd4 ! nonlinear FLUX Tau0...XLINV(I) +! + else +! + TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) + & * ULOW(I) * GFOBNV * EFACT *pgwd4 +! +! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs +! + 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 ref level +! +! diagnostics for zogw > zmtb +! + zogw(J) = PHII(j, kref(I)) *rgrav + 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 + 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.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,levs+1) = taup(1:npt,levs) +! +! 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 +! +!------scale MOMENTUM DEPOSITION AT TOP TO 1/2 VALUE +! it is zero now +! DO I = 1,npt +! TAUD(I, levs) = TAUD(I,levs) * FACTOP +! 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/decreaseof 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) + DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) +! DTFAC(I) = 1.0 + ENDIF + ENDIF + ENDDO + ENDDO +! +!--------------------------- OROGW-solver of GFS PSS-1986 +! + else +! +!--------------------------- 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, levs, npt, ipt, kref, kdt, me, master, + & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, + & del, sigma, hprime, gamma, theta, + & sinlat, xlatd, taup, taud, pkdis) + + endif ! oro_wam_2017 - LINSATDIS-solver of WAM-2017 +! +!--------------------------- 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 =rgrav*phil( j, kpbl(j) ) + + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of LS-SSO + + zsurf = phii(j,1)*rgrav + do k=1,levs + zpm(k) = phiL(j,k)*rgrav + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo + + call ugwp_tofd1d(levs, sigflt, elvmaxd(j), zsurf, zpbl, + & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,levs + 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:levs)* del(j,1:levs)) + enddo + ENDIF ! do_tofd + +!--------------------------- +! combine oro-drag effects +!--------------------------- +! + 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(phil)*rgrav,minval(phil)*rgrav, 'zmet' + print *, maxval(phii)*rgrav,minval(phii)*rgrav, 'zmeti' + print *, maxval(prsi), minval(prsi), ' prsi ' + print *, maxval(prsL), minval(prsL), ' prsL ' + print *, maxval(RO), minval(RO), ' RO-dens ' + print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' BNV2 ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' + print * + do i =1, npt + j= ipt(i) + print *,zogw(J)/hprime(j), zmtb(j)/hprime(j), + & phil(j,1)/9.81, nint(hprime(j)/sigma(j)) +! +!.................................................................... +! +! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m +! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km +! we must exclude blocking by small ridges +! VAY-kref < iblk zogw-lev 15 block-level: 39 +! +! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters +! MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) +! MAX(DW2,DW2MIN) * RDZ * RDZ +! ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) +! TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.1) +! TEMV = 1.0 / max(VELCO(I,K), 0.01) +! & * max(VELCO(I,K),0.01) +!.................................................................... + enddo + print * + stop + endif + endif + +! + RETURN +!--------------------------------------------------------------- +! review of OLD-GFS code 2017/18 most substantial changes +! a) kref > idxzb if idxzb > KPBL "OK" clipped-hill for OGW +! b) tofd -sgh30 "OK" +! +! c) FR < Frc linear theory for taub-specification +! +! d) solver of Palmer et al. (1987) => Linsat of McFarlane +! +!--------------------------------------------------------------- + end subroutine gwdps_v0 + + + +!=============================================================================== +! use fv3gfs-v0 +! first beta version of ugwp for fv3gfs-128 +! cires/swpc - jan 2018 +! non-tested wam ugwp-solvers in fv3gfs: "lsatdis", "dspdis", "ado99dis" +! they reqiure extra-work to put them in with intializtion and namelists +! next will be lsatdis for both fv3wam & fv3gfs-128l implementations +! with (a) stochastic-deterministic propagation solvers for wave packets/spectra +! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) +! (c) guidance from high-res runs for GW sources and res-aware tune-ups +!23456 +! +! call gwdrag_wam(1, im, ix, levs, ksrc, dtp, +! & xlat, gw_dudt, gw_dvdt, taux, tauy) +! call fv3_ugwp_wms17(kid1, im, ix, levs, ksrc_ifs, dtp, +! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, +! & taux,tauy,grav, amol_i, me, lstep_first ) +! +! +!23456============================================================================== + + + subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, + & tm1 , um1, vm1, qm1, + & prsl, prsi, philg, xlatd, sinlat, coslat, + & pdudt, pdvdt, pdtdt, dked, tau_ngw, mpi_id, master, kdt) +! + + +!======================================================= +! +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! --------------------------------------------------------------------------------- +! + + use ugwp_common , only : rgrav, grav, cpd, rd, rv + &, omega2, rcpd2, pi, pi2, fv + &, rad_to_deg, deg_to_rad + &, rdi, gor, grcp, gocp + &, bnv2min, dw2min, velmin, gr2 +! + use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec + &, v_kxw, v_kxw2, tamp_mpa, zfluxglob + &, maxdudt, gw_eff, dked_min + &, nslope, ilaunch, zms + &, zci, zdci, zci4, zci3, zci2 + &, zaz_fct, zcosang, zsinang + &, nwav, nazd, zcimin, zcimax +! + implicit none +!23456 + + integer, intent(in) :: klev ! vertical level + integer, intent(in) :: klon ! horiz tiles + + real ,intent(in) :: dtime ! model time step + real ,intent(in) :: vm1(klon,klev) ! meridional wind + real ,intent(in) :: um1(klon,klev) ! zonal wind + real ,intent(in) :: qm1(klon,klev) ! spec. humidity + real ,intent(in) :: tm1(klon,klev) ! kin temperature + + real ,intent(in) :: prsl(klon,klev) ! mid-layer pressure + real ,intent(in) :: philg(klon,klev) ! m2/s2-phil => meters !!!!! phil =philg/grav + real ,intent(in) :: prsi(klon,klev+1) ! prsi interface pressure + real ,intent(in) :: xlatd(klon) ! lat was in radians, now with xlat_d in degrees + real ,intent(in) :: sinlat(klon) + real ,intent(in) :: coslat(klon) + real ,intent(in) :: tau_ngw(klon) + + integer, intent(in):: mpi_id, master, kdt +! +! +! out-gw effects +! + real ,intent(out) :: pdudt(klon,klev) ! zonal momentum tendency + real ,intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency + real ,intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp + real ,intent(out) :: dked(klon,klev) ! gw-eddy diffusion + real, parameter :: minvel = 0.5 ! + +!vay-2018 + + real :: taux(klon,klev+1) ! EW component of vertical momentum flux (pa) + real :: tauy(klon,klev+1) ! NS component of vertical momentum flux (pa) + real :: phil(klon,klev) ! gphil/grav +! +! local =============================================================================================== +! + +! real :: zthm1(klon,klev) ! temperature interface levels + real :: zthm1 ! 1.0 / temperature interface levels + real :: zbvfhm1(klon,ilaunch:klev) ! interface BV-frequency + real :: zbn2(klon,ilaunch:klev) ! interface BV-frequency + real :: zrhohm1(klon,ilaunch:klev) ! interface density + real :: zuhm1(klon,ilaunch:klev) ! interface zonal wind + real :: zvhm1(klon,ilaunch:klev) ! meridional wind + real :: v_zmet(klon,ilaunch:klev) + real :: vueff(klon,ilaunch:klev) + real :: zbvfl(klon) ! BV at launch level + real :: c2f2(klon) + +!23456 + real :: zul(klon,nazd) ! velocity in azimuthal direction at launch level + real :: zci_min(klon,nazd) + real :: zcrt(klon,klev,nazd) + real :: zact(klon, nwav, nazd) ! if =1 then critical level encountered => c-u + real :: zacc(klon, nwav, nazd) +! + real :: zpu(klon,klev, nazd) ! momentum flux + real :: zdfl(klon,klev, nazd) + real :: zfct(klon,klev) + real :: zfnorm(klon) ! normalisation factor + + real :: zfluxlaun(klon) + real :: zui(klon, klev,nazd) +! + real :: zdfdz_v(klon,klev, nazd) ! axj = -df*rho/dz directional momentum depositiom + real :: zflux(klon, nwav, nazd) ! momentum flux at each level stored as ( ix, mode, iazdim) + + real :: zflux_z (klon, nwav,klev) !momentum flux at each azimuth stored as ( ix, mode, klev) +! + real :: vm_zflx_mode, vc_zflx_mode + real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2 + + real :: zang, znorm, zang1, ztx + real :: zu, zcin, zcpeak, zcin4, zbvfl4 + real :: zcin2, zbvfl2, zcin3, zbvfl3, zcinc + real :: zatmp, zfluxs, zdep, zfluxsq, zulm, zdft, ze1, ze2 + +! + real :: zdelp,zrgpts + real :: zthstd,zrhostd,zbvfstd + real :: tvc1, tvm1 + real :: zhook_handle + + +! real :: rcpd, grav2cpd + real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g + &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp + + real :: fmode, expdis, fdis + real :: v_kzi, v_kzw, v_cdp, v_wdp, sc, tx1 + + integer :: j, k, inc, jk, jl, iazi +! +!-------------------------------------------------------------------------- +! + do k=1,klev + do j=1,klon + pdvdt(j,k) = 0.0 + pdudt(j,k) = 0.0 + pdtdt(j,k) = 0.0 + dked(j,k) = 0.0 + phil(j,k) = philg(j,k) * rgrav + enddo + enddo +!----------------------------------------------------------- +! also other options to alter tropical values +! tamp = 100.e-3*1.e3 = 100 mpa +! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 +!----------------------------------------------------------- +! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) + + +! phil = philg*rgrav + +! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] +! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp + + if (kdt ==1 .and. mpi_id == master) then + print *, maxval(tm1), minval(tm1), 'vgw: temp-res ' + print *, 'ugwp-v0: zcimin=' , zcimin + print *, 'ugwp-v0: zcimax=' , zcimax + print * + endif +! +!================================================= + do iazi=1, nazd + do jk=1,klev + do jl=1,klon + zpu(jl,jk,iazi) = 0.0 + zcrt(jl,jk,iazi) = 0.0 + zdfl(jl,jk,iazi) = 0.0 + enddo + enddo + enddo + +! +! set initial min Cxi for critical level absorption + do iazi=1,nazd + do jl=1,klon + zci_min(jl,iazi) = zcimin + enddo + enddo +! define half model level winds and temperature +! --------------------------------------------- + do jk=max(ilaunch,2),klev + do jl=1,klon + tvc1 = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) + tvm1 = tm1(jl,jk-1) * (1. +fv*qm1(jl,jk-1)) +! zthm1(jl,jk) = 0.5 *(tvc1+tvm1) + zthm1 = 2.0 / (tvc1+tvm1) + zuhm1(jl,jk) = 0.5 *(um1(jl,jk-1)+um1(jl,jk)) + zvhm1(jl,jk) = 0.5 *(vm1(jl,jk-1)+vm1(jl,jk)) +! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) + zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) + zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters + v_zmet(jl,jk) = 2.*zdelp + vueff(jl,jk) = + & 2.e-5*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min +! +! zbn2(jl,jk) = grav2cpd/zthm1(jl,jk) + zbn2(jl,jk) = grav2cpd*zthm1 + & * (1.0+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) + zbn2(jl,jk) = max(min(zbn2(jl,jk), gssec), bv2min) + zbvfhm1(jl,jk) = sqrt(zbn2(jl,jk)) ! bn = sqrt(bn2) + enddo + enddo + + if (ilaunch == 1) then + jk = 1 + do jl=1,klon +! zthm1(jl,jk) = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) ! not used + zuhm1(jl,jk) = um1(jl,jk) + zvhm1(jl,jk) = vm1(jl,jk) + ZBVFHM1(JL,1) = ZBVFHM1(JL,2) + V_ZMET(JL,1) = V_ZMET(JL,2) + VUEFF(JL,1) = DKED_MIN + ZBN2(JL,1) = ZBN2(JL,2) + enddo + endif + do jl=1,klon + tx1 = OMEGA2 * SINLAT(JL) / V_KXW + C2F2(JL) = tx1 * tx1 + zbvfl(jl) = zbvfhm1(jl,ilaunch) + enddo +! +! define intrinsic velocity (relative to launch level velocity) u(z)-u(zo), and coefficinets +! ------------------------------------------------------------------------------------------ + do iazi=1, nazd + do jl=1,klon + zul(jl,iazi) = zcosang(iazi) * zuhm1(jl,ilaunch) + & + zsinang(iazi) * zvhm1(jl,ilaunch) + enddo + enddo +! + do jk=ilaunch, klev-1 ! from z-launch up model level from which gw spectrum is launched + do iazi=1, nazd + do jl=1,klon + zu = zcosang(iazi)*zuhm1(jl,jk) + & + zsinang(iazi)*zvhm1(jl,jk) + zui(jl,jk,iazi) = zu - zul(jl,iazi) + enddo + enddo + + enddo +! define rho(zo)/n(zo) +! ------------------- + do jk=ilaunch, klev-1 + do jl=1,klon + zfct(jl,jk) = zrhohm1(jl,jk) / zbvfhm1(jl,jk) + enddo + enddo + +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + if(nslope == 1) then ! s=1 case + ! -------- + do inc=1,nwav + zcin = zci(inc) + zcin4 = zci4(inc) + do jl=1,klon +!n4 + zbvfl4 = zbvfl(jl) * zbvfl(jl) + zbvfl4 = zbvfl4 * zbvfl4 + zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl4*zcin + & / (zbvfl4+zcin4) + enddo + enddo + elseif(nslope == 2) then ! s=2 case + ! -------- + do inc=1, nwav + zcin = zci(inc) + zcin4 = zci4(inc) + do jl=1,klon + zbvfl4 = zbvfl(jl)*zbvfl(jl) + zbvfl4 = zbvfl4 * zbvfl4 + zcpeak = zbvfl(jl)/zms + zflux(jl,inc,1) = zfct(jl,ilaunch)* + & zbvfl4*zcin*zcpeak/(zbvfl4*zcpeak+zcin4*zcin) + enddo + enddo + elseif(nslope == -1) then ! s=-1 case + ! -------- + do inc=1,nwav + zcin = zci(inc) + zcin2 = zci2(inc) + do jl=1,klon + zbvfl2 = zbvfl(jl)*zbvfl(jl) + zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl2*zcin + & / (zbvfl2+zcin2) + enddo + enddo + elseif(nslope == 0) then ! s=0 case + ! -------- + + do inc=1, nwav + zcin = zci(inc) + zcin3 = zci3(inc) + do jl=1,klon + zbvfl3 = zbvfl(jl)**3 + zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl3*zcin + & / (zbvfl3+zcin3) + enddo + enddo + + endif ! for slopes +! +! normalize momentum flux at the src-level +! ------------------------------ +! integrate (zflux x dx) + do inc=1, nwav + zcinc = zdci(inc) + do jl=1,klon + zpu(jl,ilaunch,1) = zpu(jl,ilaunch,1) + zflux(jl,inc,1)*zcinc + enddo + enddo +! +! normalize and include lat-dep (precip or merra-2) +! ----------------------------------------------------------- +! also other options to alter tropical values +! + do jl=1,klon + zfluxlaun(jl) = tau_ngw(jl) !*(.5+.75*coslat(JL)) !zfluxglob/2 on poles + zfnorm(jl) = zfluxlaun(jl) / zpu(jl,ilaunch,1) + enddo +! + do iazi=1,nazd + do jl=1,klon + zpu(jl,ilaunch,iazi) = zfluxlaun(jl) + enddo + enddo + +! adjust constant zfct + + do jk=ilaunch, klev-1 + do jl=1,klon + zfct(jl,jk) = zfnorm(jl)*zfct(jl,jk) + enddo + enddo +! renormalize each spectral mode + + do inc=1, nwav + do jl=1,klon + zflux(jl,inc,1) = zfnorm(jl)*zflux(jl,inc,1) + enddo + enddo + +! copy zflux into all other azimuths +! -------------------------------- + zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 + do iazi=2, nazd + do inc=1,nwav + do jl=1,klon + zflux(jl,inc,iazi) = zflux(jl,inc,1) + enddo + enddo + enddo + +! ------------------------------------------------------------- +! azimuth do-loop +! -------------------- + do iazi=1, nazd +! vertical do-loop +! ---------------- + do jk=ilaunch, klev-1 +! first check for critical levels +! ------------------------ + do jl=1,klon + zci_min(jl,iazi) = max(zci_min(jl,iazi),zui(jl,jk,iazi)) + enddo +! set zact to zero if critical level encountered +! ---------------------------------------------- + do inc=1, nwav + zcin = zci(inc) + do jl=1,klon + zatmp = minvel + sign(minvel,zcin-zci_min(jl,iazi)) + zacc(jl,inc,iazi) = zact(jl,inc,iazi)-zatmp + zact(jl,inc,iazi) = zatmp + enddo + enddo +! +! integrate to get critical-level contribution to mom deposition +! --------------------------------------------------------------- + do inc=1, nwav + zcinc = zdci(inc) + do jl=1,klon + zdfl(jl,jk,iazi) = zdfl(jl,jk,iazi) + + & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zcinc + enddo + enddo +! -------------------------------------------- +! get weighted average of phase speed in layer +! -------------------------------------------- + do jl=1,klon + if(zdfl(jl,jk,iazi) > 0.0 ) then + zatmp = zcrt(jl,jk,iazi) + do inc=1, nwav + zatmp = zatmp + zci(inc) * + & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zdci(inc) + enddo +! + zcrt(jl,jk,iazi)=zatmp/zdfl(jl,jk,iazi) + else + zcrt(jl,jk,iazi)=zcrt(jl,jk-1,iazi) + endif + enddo + +! + do inc=1, nwav + zcin = zci(inc) + zcinc = 1.0 / zcin + do jl=1,klon +!======================================================================= +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +! define kxw = +!======================================================================= + v_cdp = abs(zcin-zui(jL,jk,iazi)) + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + cdf2 = v_cdp*v_cdp - c2f2(jL) + if (cdf2 > 0) then + kzw2 = (zBn2(jL,jk)-wdop2)/Cdf2 - v_kxw2 + else + kzw2 = 0.0 + endif + if ( kzw2 > 0 ) then + v_kzw = sqrt(kzw2) +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (zBn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NiGW (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_kzi = abs(v_kzw*v_kzw*vueff(jl,jk)/v_wdp*v_kzw) + expdis = exp(-v_kzi*v_zmet(jl,jk)) + else + v_kzi = 0. + expdis = 1.0 + v_kzw = 0. + v_cdp = 0. ! no effects of reflected waves + endif + + fmode = zflux(jl,inc,iazi) + fdis = fmode*expdis +! +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! + zfluxs= zfct(jl,jk)*v_cdp*v_cdp*zcinc +! +! zfluxs= zfct(jl,jk)*(zcin-zui(jl,jk,iazi))**2/zcin +! flux_tot - sat.flux +! + + zdep = zact(jl,inc,iazi)* (fdis-zfluxs) + if(zdep > 0.0 ) then +! subs on sat-limit + zflux(jl,inc,iazi) = zfluxs + zflux_z(jl,inc,jk) = zfluxs + else +! assign dis-ve flux + zflux(jl,inc,iazi) = fdis + zflux_z(jl,inc,jk) = fdis + endif + enddo + enddo +! +! integrate over spectral modes zpu(y, z, azimuth) zact(jl,inc,iazi)*zflux(jl,inc,iazi)*[d("zcinc")] +! + zdfdz_v(:,jk,iazi) = 0.0 + + do inc=1, nwav + zcinc=zdci(inc) ! dc-integration + do jl=1,klon + vc_zflx_mode = zact(jl,inc,iazi)*zflux(jl,inc,iazi) + zpu(jl,jk,iazi) = zpu(jl,jk,iazi) + vc_zflx_mode*zcinc + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! check monotonic decrease +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (jk > ilaunch)then + zdelp = grav/(prsi(jl,jk-1)-prsi(jl,jk))* + & abs(zcin-zui(jl,jk,iazi)) *zcinc + vm_zflx_mode = zact(jl,inc,iazi)* zflux_z(jl,inc,jk-1) + + if (vc_zflx_mode > vm_zflx_mode) + & vc_zflx_mode = vm_zflx_mode ! no-flux increase + zdfdz_v( jl,jk,iazi) = zdfdz_v( jl,jk,iazi) + + & (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 +! +! + endif + enddo !jl=1,klon + enddo !waves inc=1,nwav + +! -------------- + enddo ! end jk do-loop vertical loop +! --------------- + enddo ! end nazd do-loop +! ---------------------------------------------------------------------------- +! sum contribution for total zonal and meridional flux + +! energy dissipation +! --------------------------------------------------- +! + do jk=1,klev+1 + do jl=1,klon + taux(jl,jk) = 0.0 + tauy(jl,jk) = 0.0 + enddo + enddo + + do iazi=1,nazd + do jk=ilaunch, klev-1 + do jl=1,klon + taux(jl,jk) = taux(jl,jk) + & + zpu(jl,jk,iazi)*zaz_fct*zcosang(iazi) ! zaz_fct - "azimuth"-norm-n + tauy(jl,jk) = tauy(jl,jk) + & + zpu(jl,jk,iazi)*zaz_fct*zsinang(iazi) + pdtdt(jl,jk) = pdtdt(jl,jk) + & + zdfdz_v(jl,jk,iazi)*zaz_fct/cpd ! eps_dis =sum( +d(flux_e)/dz) > 0. + enddo + enddo + + enddo +! +! update du/dt and dv/dt tendencies ..... no contribution to heating => keddy/tracer-mom-heat +! ---------------------------- +! + + do jk=ilaunch,klev + do jl=1, klon + zdelp = grav / (prsi(jl,jk-1)-prsi(jl,jk)) + ze1 = (taux(jl,jk)-taux(jl,jk-1))*zdelp + ze2 = (tauy(jl,jk)-tauy(jl,jk-1))*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 +! + pdtdt(jl,jk) = (ze1*um1(jl,jk) + ze2*vm1(jl,jk))/cpd +! + dked(jl,jk) = max(dked_min, pdtdt(jl,jk)/zbn2(jl,jk)) +! if (dked(jl,jk) < 0) dked(jl,jk) = dked_min + enddo + enddo +! +! add limiters/efficiency for "unbalanced ics" if it is needed +! + do jk=ilaunch,klev + do jl=1, klon + pdudt(jl,jk) = gw_eff * pdudt(jl,jk) + pdvdt(jl,jk) = gw_eff * pdvdt(jl,jk) + pdtdt(jl,jk) = gw_eff * pdtdt(jl,jk) + dked(jl,jk) = gw_eff * dked(jl,jk) + enddo + enddo +! +!--------------------------------------------------------------------------- +! + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done ' +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps' +! +! print *, ' ugwp -heating rates ' + endif + + return + end subroutine fv3_ugwp_solv2_v0 +!------------------------------------------------------------------------------- +! +! Part-3 of UGWP-V01 Dissipative (eddy) effects of UGWP it will be activated +! after tests of OGW (new revision) and NGW with MERRA-2 forcing. +! +!------------------------------------------------------------------------------- + subroutine edmix_ugwp_v0(im, levs, dtp, + & t1, u1, v1, q1, del, + & prsl, prsi, phil, prslk, + & pdudt, pdvdt, pdTdt, pkdis, + & ed_dudt, ed_dvdt, ed_dTdt, + & me, master, kdt ) +! + use machine, only : kind_phys + use ugwp_common , only : rgrav, grav, cpd, rd, rdi, fv +! &, pi, rad_to_deg, deg_to_rad, pi2 + &, bnv2min, velmin, arad + + implicit none + + integer, intent(in) :: me, master, kdt + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtp + real(kind=kind_phys), intent(in), dimension(im,levs) :: + & u1, v1, t1, q1, del, prsl, prslk, phil +! + real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi + real(kind=kind_phys),dimension(im,levs) :: pdudt, pdvdt, pdTdt + real(kind=kind_phys),dimension(im,levs) :: pkdis +! +! out +! + real(kind=kind_phys),dimension(im,levs) :: ed_dudt, ed_dvdt + real(kind=kind_phys),dimension(im,levs) :: ed_dTdt +! +! locals +! + integer :: i, j, k +!------------------------------------------------------------------------ +! solving 1D-vertical eddy diffusion to "smooth" +! GW-related tendencies: du/dt, dv/dt, d(PT)/dt +! we need to use sum of molecular + eddy terms including turb-part +! of PBL extended to the model top, because "phys-tend" dx/dt +! should be smoothed as "entire" fields therefore one should +! first estimate and collect "effective" diffusion and applied +! it to each part of tendency or "sum of tendencies + Xdyn" +! this "diffusive-way" is tested with UGWP-tendencies +! forced by various wave sources. X' =dx/dt *dt +! d(X + X')/dt = K*diff(X + X') => +! +! wave1 dX'/dt = Kw * diff(X')... eddy part "Kwave" on wave-part +! turb2 dX/dt = Kturb * diff(X) ... resolved scale mixing "Kturb" like PBL +! we may assume "zero-GW"-tendency at the top lid and "zero" flux +! or "vertical gradient" near the surface +! +! 1-st trial w/o PBL interactions: add dU, dV dT tendencies +! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " +! ed_X = X_ed - X => final eddy tendencies +!--------------------------------------------------------------------------- +! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) +! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp +! + real(kind=kind_phys) :: Sw(levs), Sw1(levs), Fw(levs), Fw1(levs) + real(kind=kind_phys) :: Km(levs), Kpt(levs), Pt(levs), Ptmap(levs) + real(kind=kind_phys) :: rho(levs), rdp(levs), rdpm(levs-1) + real(kind=kind_phys),dimension(levs) :: ktur, vumol, up, vp, tp + real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum + real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis + real(kind=kind_phys) :: rdz , uz, vz, ptz +! ------------------------------------------------------------------------- +! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt +! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) +! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit +! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 +! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 +! + real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 + real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb + real(kind=kind_phys),parameter :: ulturb=150.,sc2u=ulturb* ulturb + real(kind=kind_phys), parameter :: ric =0.25 + real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 + real(kind=kind_phys), parameter :: prmax = 4.0 + real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps + real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. + + + real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur + integer :: nstab + real(kind=kind_phys) :: w1, w2, w3 + rdtp = 1./dtp + nstab = 1 + stab_dt = 0.9999 + + do i =1, im + + rdp(1:levs) = grav/del(i, 1:levs) + + up(1:levs) = u1(i,1:levs) +pdudt(i,1:levs)*dtp + vp(1:levs) = v1(i,1:levs) +pdvdt(i,1:levs)*dtp + tp(1:levs) = t1(i,1:levs) +pdTdt(i,1:levs)*dtp + Ptmap(1:levs) = (1.+fv*q1(i,1:levs))/prslk(i,1:levs) + rho(1:levs) = rdi*prsl(i, 1:levs)/tp(1:levs) + Pt(1:levs) = tp(1:levs)*Ptmap(1:levs) + + do k=1, levs-1 + rdpm(k) = grav/(prsl(i,k)-prsl(i,k+1)) + rdz = .5*rdpm(k)*(rho(k)+rho(k+1)) + uz = up(k+1)-up(k) + vz = vp(k+1)-vp(k) + ptz =2.*(pt(k+1)-pt(k))/(pt(k+1)+pt(k)) + shr2(k) = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) + bn2(k) = grav*rdz*ptz + zmet = phil(j,k)*rgrav + zgrow = exp(zmet*h4) + if ( bn2(k) < 0. ) then +! +! adjust PT-profile to bn2(k) = bnv2min -- neutral atmosphere +! adapt "pdtdt = (Ptadj-Ptdyn)/Ptmap" +! + print *,' UGWP-V0 unstab PT(z) via gwdTdt ', bn2(k), k + + rineg = bn2(k)/shr2(k) + bn2(k) = max(bn2(k), bnv2min) + kamp = sqrt(shr2(k))*sc2u *zgrow + ktur(k) =kamp* (1+8.*(-rineg)/(1+1.746*sqrt(-rineg))) + endif + ritur = max(bn2(k)/shr2(k), rimin) + if (ritur > 0. ) then + kamp = sqrt(shr2(k))*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k)= kamp * w1 * w1 + endif + vumol(k) = 2.e-5 *exp(zmet/hps) + ksum(k) =ktur(k)+Pkdis(i,k)+vumol(k) + ksum(k) = max(ksum(k), kedmin) + ksum(k) = min(ksum(k), kedmax) + stab = 2.*ksum(k)*rdz*rdz*dtp + if ( stab >= 1.0 ) then + stab_dt = max(stab_dt, stab) + endif + enddo + nstab = max(1, nint(stab_dt)+1) + dtstab = dtp / float(nstab) + ksum(levs) = ksum(levs-1) + Fw(1:levs) = pdudt(i, 1:levs) + Fw1(1:levs) = pdvdt(i, 1:levs) + Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) + + do j=1, nstab + call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, + & del(i,:), Sw, Sw1) + Fw = Sw + Fw1 = Sw1 + enddo + + ed_dudt(i,:) = Sw + ed_dvdt(i,:) = Sw1 + + Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) + Kpt = Km*iPr_pt + Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) + do j=1, nstab + call diff_1d_ptend(levs, dtstab, Fw, Kpt, del(i,:), Sw) + Fw = Sw + enddo + ed_dtdt(i,1:levs) = Sw(1:levs)/Ptmap(1:levs) + + enddo + + end subroutine edmix_ugwp_v0 + + subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) + use machine, only: kind_phys + implicit none + integer :: levs + real(kind=kind_phys) :: dt + real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) + real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) + integer :: i, k + real(kind=kind_phys) :: Km1, Kp1, ad, cd, bd +! S(:) = 0.0 ; S1(:) = 0.0 +! +! explicit diffusion solver +! + k = 1 + km1 = 0. ; ad =0. + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(1)*rdpm(1)*kp1*dt + bd = 1. - cd - ad +! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + S(K) = F(k) + S1(K) = F1(k) + do k=2, levs-1 + ad = cd + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(k)*rdpm(k)*kp1*dt + bd = 1.-(ad +cd) + S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) + enddo + k = levs + S(k) = F(k) + S1(k) = F1(k) + end subroutine diff_1d_wtend + + subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) + use machine, only: kind_phys + implicit none + integer :: levs + real(kind=kind_phys) :: dt + real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) + real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) + integer :: i, k + real(kind=kind_phys) :: Km1, Kp1, ad, cd, bd +! +! explicit "eddy" smoother for tendencies +! + + k = 1 + km1 = 0. ; ad =0. + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(1)*rdpm(1)*kp1*dt + bd = 1. -(cd +ad) +! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + S(K) = F(k) + do k=2, levs-1 + ad = cd + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(k)*rdpm(k)*kp1*dt + bd = 1.-(ad +cd) + S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + enddo + k =levs + S(k) = F(k) + end subroutine diff_1d_ptend