diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2db523355..3e8e987c7 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -675,6 +675,31 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if + ! UGWP - incomplete list + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%dudt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%dvdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%dtdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%kdis_gw) + if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_obl ', Diag%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_oss ', Diag%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_oss ', Diag%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ofd ', Diag%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ofd ', Diag%dvdt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ogwcol ', Diag%du_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ogwcol ', Diag%dv_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_oblcol ', Diag%du_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_oblcol ', Diag%dv_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_osscol ', Diag%du_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_osscol ', Diag%dv_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) + else + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw) + end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsi' , Statein%prsi) @@ -824,8 +849,12 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_h', Grid%jindx1_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_h', Grid%jindx2_h) endif - ! Model/Control - ! not yet + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j1tau ', Grid%ddy_j1tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j2tau ', Grid%ddy_j2tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_tau', Grid%jindx1_tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_tau', Grid%jindx2_tau ) + endif end if #ifdef OPENMP !$OMP BARRIER @@ -1229,23 +1258,28 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) - ! CIRES UGWP v0 - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + ! UGWP call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) + ! UGWP v1 + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ngw ', Interstitial%dudt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ngw ', Interstitial%dvdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_ngw ', Interstitial%dtdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_ngw ', Interstitial%kdis_ngw ) + end if !-- GSD drag suite - if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then + if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & + Model%gwd_opt==2 .or. Model%gwd_opt==22) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ocss ', Interstitial%ocss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 84c284540..e33585ace 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -2,8 +2,8 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, -!! aerosol, IN&CCN and surface properties updates. +!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary @@ -29,6 +29,9 @@ module GFS_phys_time_vary use gcycle_mod, only : gcycle + use cires_tauamf_data, only: cires_indx_ugwp, read_tau_amf, tau_amf_interp + use cires_tauamf_data, only: tau_limb, days_limb, ugwp_taulat + !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx use set_soilveg_mod, only: set_soilveg @@ -60,6 +63,7 @@ subroutine GFS_phys_time_vary_init ( jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_ruc, min_seaice, fice, landfrac, & vtype, weasd, nthrds, errmsg, errflg) @@ -80,6 +84,9 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) + logical, intent(in) :: do_ugwp_v1 + real(kind_phys), intent(inout) :: ddy_j1tau(:), ddy_j2tau(:) + integer, intent(inout) :: jindx1_tau(:), jindx2_tau(:) integer, intent(in) :: isot, ivegsrc, nlunit real(kind_phys), intent(inout) :: sncovr(:), sncovr_ice(:) @@ -110,6 +117,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & +!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & !$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & !$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & !$OMP private (ix,i,j,rsnow,vegtyp) @@ -117,7 +125,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP sections !$OMP section -!> - Call read_o3data() to read ozone data +!> - Call read_o3data() to read ozone data call read_o3data (ntoz, me, master) ! Consistency check that the hardcoded values for levozp and @@ -189,6 +197,12 @@ subroutine GFS_phys_time_vary_init ( ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif +!$OMP section +!> - Call tau_amf dats for ugwp_v1 + if (do_ugwp_v1) then + call read_tau_amf(me, master, errmsg, errflg) + endif + !$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) call set_soilveg(me, isot, ivegsrc, nlunit) @@ -228,6 +242,13 @@ subroutine GFS_phys_time_vary_init ( iindx1_ci, iindx2_ci, ddx_ci) endif +!$OMP section +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs + if (do_ugwp_v1) then + call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau) + endif + !$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 @@ -293,7 +314,8 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, errmsg, errflg) + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -317,6 +339,12 @@ subroutine GFS_phys_time_vary_timestep_init ( real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 real(kind_phys), intent(inout) :: rann(:,:) + + logical, intent(in) :: do_ugwp_v1 + integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) + real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) + real(kind_phys), intent(inout) :: tau_amf(:) + ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc @@ -331,7 +359,7 @@ subroutine GFS_phys_time_vary_timestep_init ( zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) - ! + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -425,6 +453,13 @@ subroutine GFS_phys_time_vary_timestep_init ( levs, prsl, in_nm, ccn_nm) endif +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that resolve GW-activ + if (do_ugwp_v1) then + call tau_amf_interp(me, master, im, idate, fhour, & + jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau, tau_amf) + endif + !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN @@ -500,6 +535,11 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (allocated(ccnin) ) deallocate(ccnin) if (allocated(ci_pres) ) deallocate(ci_pres) + ! Deallocate UGWP-input arrays + if (allocated(ugwp_taulat)) deallocate(ugwp_taulat) + if (allocated(tau_limb )) deallocate(tau_limb) + if (allocated(days_limb )) deallocate(days_limb) + is_initialized = .false. end subroutine GFS_phys_time_vary_finalize diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 4a625f6c0..393874cae 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F + dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f + dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] @@ -307,6 +308,48 @@ type = integer intent = inout optional = F +[do_ugwp_v1] + standard_name = flag_for_ugwp_version_1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[jindx1_tau] + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[jindx2_tau] + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[ddy_j1tau] + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F [isot] standard_name = soil_type_dataset_choice long_name = soil type dataset choice @@ -553,7 +596,7 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer intent = in @@ -1438,6 +1481,57 @@ kind = kind_phys intent = inout optional = F +[do_ugwp_v1] + standard_name = flag_for_ugwp_version_1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[jindx1_tau] + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[jindx2_tau] + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[ddy_j1tau] + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[tau_amf] + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f index 4170a3d79..c20f98f42 100644 --- a/physics/cires_orowam2017.f +++ b/physics/cires_orowam2017.f @@ -4,7 +4,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & sinlat, xlatd, taup, taud, pkdis) ! USE MACHINE , ONLY : kind_phys - use ugwp_common , only : grav, omega2 + use ugwp_common_v0 , only : grav, omega2 ! implicit none @@ -121,7 +121,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, taub_kx(1:nw) = tau_kx(1:nw) * taub(i) wkdis(:,:) = kedmin - call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), + call oro_meanflow_v0(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & xn(i), yn(i)) @@ -275,10 +275,10 @@ end subroutine oro_wam_2017 ! define mean flow and dissipation for OGW-kx spectrum ! !------------------------------------------------------------- - subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, + subroutine oro_meanflow_v0(nz, nzi, u1, v1, t1, pint, pmid, & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) - use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min + use ugwp_common_v0 , only : grav, rgrav, rdi, velmin, dw2min implicit none integer :: nz, nzi @@ -336,4 +336,51 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, rhoi(k) = rhoi(k-1)*.5 dzi(k) = dzi(k-1) - end subroutine oro_meanflow + end subroutine oro_meanflow_v0 + + subroutine ugwpv0_tofd1d(levs, sigflt, elvmax, zsurf, + & zpbl, u, v, zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common_v0 , only : rcpd2 + use ugwpv0_oro_init, only : n_tofd, const_tofd, ze_tofd + use ugwpv0_oro_init, only : a12_tofd, ztop_tofd +! + implicit none + integer :: levs + real(kind_phys), dimension(levs) :: u, v, zmid + real(kind_phys) :: sigflt, elvmax, zpbl, zsurf + real(kind_phys), dimension(levs) :: utofd, vtofd + real(kind_phys), dimension(levs) :: epstofd, krf_tofd +! +! locals +! + integer :: i, k + real(kind_phys) :: sghmax = 5. + real(kind_phys) :: sgh2, ekin, zdec, rzdec, umag, zmet + real(kind_phys) :: zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 + epstofd =0.0 ; krf_tofd =0.0 +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed 18 km + rzdec = 1.0/zdec + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + ekin = u(k)*u(k) + v(k)*v(k) + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf + enddo +! + end subroutine ugwpv0_tofd1d diff --git a/physics/cires_tauamf_data.F90 b/physics/cires_tauamf_data.F90 new file mode 100644 index 000000000..e0d43e74e --- /dev/null +++ b/physics/cires_tauamf_data.F90 @@ -0,0 +1,213 @@ +module cires_tauamf_data + + use machine, only: kind_phys +!........................................................................................... +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +!........................................................................................... +implicit none + + integer :: ntau_d1y, ntau_d2t + real(kind=kind_phys), allocatable :: ugwp_taulat(:) + real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) + logical :: flag_alloctau = .false. + character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' + + public :: read_tau_amf, cires_indx_ugwp, tau_amf_interp + +contains + + subroutine read_tau_amf(me, master, errmsg, errflg) + + use netcdf + integer, intent(in) :: me, master + integer :: ncid, iernc, vid, dimid, status + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! + + iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) + + if(iernc.ne.0) then + write(errmsg,'(*(a))') "read_tau_amf: cannot open file_limb_tab data-file ", & + trim(ugwp_taufile) + print *, 'cannot open ugwp-v1 tau-file=',trim(ugwp_taufile) + errflg = 1 + return + else + + + status = nf90_inq_dimid(ncid, "lat", DimID) +! if (status /= nf90_noerr) call handle_err(status) +! + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d1y ) + + status = nf90_inq_dimid(ncid, "days", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) + + if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd of tau_ngw ugwp-v1 ' + if (ntau_d2t .le. 0 .or. ntau_d1y .le. 0) then + print *, 'ugwp-v1 tau-file=', trim(ugwp_taufile) + print *, ' ugwp-v1: ', 'ntau_d2t=',ntau_d2t, 'ntau_d2t=',ntau_d1y + stop + endif + + if (.not.allocated(ugwp_taulat)) allocate (ugwp_taulat(ntau_d1y )) + if (.not.allocated(days_limb)) allocate (days_limb(ntau_d2t)) + if (.not.allocated(tau_limb)) allocate (tau_limb(ntau_d1y, ntau_d2t )) + + iernc=nf90_inq_varid( ncid, 'DAYS', vid ) + iernc= nf90_get_var( ncid, vid, days_limb) + iernc=nf90_inq_varid( ncid, 'LATS', vid ) + iernc= nf90_get_var( ncid, vid, ugwp_taulat) + iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) + iernc= nf90_get_var( ncid, vid, tau_limb) + + iernc=nf90_close(ncid) + + endif + + end subroutine read_tau_amf + + subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: npts, me, master + real(kind=kind_phys) , dimension(npts), intent(in) :: dlat + + integer, dimension(npts), intent(inout) :: j1_tau, j2_tau + real(kind=kind_phys) , dimension(npts), intent(inout) :: w1_j1tau, w2_j2tau + +!locals + + integer :: i,j, j1, j2 +! + do j=1,npts + j2_tau(j) = ntau_d1y + do i=1,ntau_d1y + if (dlat(j) < ugwp_taulat(i)) then + j2_tau(j) = i + exit + endif + enddo + + + j2_tau(j) = min(j2_tau(j),ntau_d1y) + j1_tau(j) = max(j2_tau(j)-1,1) + + if (j1_tau(j) /= j2_tau(j) ) then + w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & + / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) + else + w2_j2tau(j) = 1.0 + endif + w1_j1tau(j) = 1.0 - w2_j2tau(j) + enddo + return + end subroutine cires_indx_ugwp + + subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) + use machine, only: kind_phys + implicit none + +!input + integer, intent(in) :: me, master + integer, intent(in) :: im, idate(4) + real(kind=kind_phys), intent(in) :: fhour + + real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1, ddy_j2 + integer , intent(in), dimension(im) :: j1_tau,j2_tau +!ouput + real(kind=kind_phys), dimension(im) :: tau_ddd +!locals + + integer :: i, j1, j2, it1, it2 , iday + integer :: ddd + real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd +! +! define day of year ddd ..... from the old-fashioned "GFS-style" +! + call gfs_idate_calendar(idate, fhour, ddd, fddd) + + it1 = 2 + do iday=1, ntau_d2t + if (fddd .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo + + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' Error in time-interpolation for tau_amf_interp ' + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + print *, ' Error in time-interpolation see cires_tauamf_data.F90 ' + stop + endif + + w2 = (fddd-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 + + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1(i)+tau_limb(j2, it1)*ddy_j2(i) + tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) + tau_ddd(i) = tx1*w1 + w2*tx2 + enddo + + end subroutine tau_amf_interp + + subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) + + use machine, only: kind_phys + implicit none +! input + integer, intent(in) :: idate(4) + real(kind=kind_phys), intent(in) :: fhour +!out + integer, intent(out) :: ddd + real(kind=kind_phys), intent(out) :: fddd +! +!locals +! + real(kind=kind_phys) :: rinc(5), rjday + integer :: jdow, jdoy, jday + real(4) :: rinc4(5) + integer :: w3kindreal, w3kindint + + integer :: iw3jdn + integer :: jd1, jddd + + integer idat(8),jdat(8) + + + idat(1:8) = 0 + idat(1) = idate(4) + idat(2) = idate(2) + idat(3) = idate(3) + idat(5) = idate(1) + rinc(1:5) = 0. + rinc(2) = fhour +! + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4 = rinc + call w3movdat(rinc4, idat,jdat) + else + call w3movdat(rinc, idat,jdat) + endif +! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow, ddd, jday) + fddd = float(ddd) + jdat(5) / 24. + end subroutine gfs_idate_calendar + +end module cires_tauamf_data diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 21b331041..672a2ac81 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -14,7 +14,7 @@ module cires_ugwp use machine, only: kind_phys - use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run @@ -77,7 +77,7 @@ subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return if (do_ugwp .or. cdmbgwd(3) > 0.0) then - call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + call cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) else @@ -120,7 +120,7 @@ subroutine cires_ugwp_finalize(errmsg, errflg) if (.not.is_initialized) return - call cires_ugwp_mod_finalize() + call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -293,7 +293,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (cdmbgwd(3) > 0.0) then ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing - call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -365,27 +365,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. endif -#if 0 - !============================================================================= - ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving - ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" - !============================================================================= - ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies - !------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, qgrs(:,:,1), & - del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) - gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked - gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked - gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked -#endif - if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index d7d7da286..e2afbf70f 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -1,8 +1,9 @@ [ccpp-table-properties] name = cires_ugwp type = scheme -# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp! - dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90,cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90,cires_vert_wmsdis.F90,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F +# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F ######################################################################## [ccpp-arg-table] @@ -564,7 +565,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -573,7 +574,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -582,7 +583,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -591,7 +592,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -672,7 +673,7 @@ intent = out optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -681,7 +682,7 @@ intent = out optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/cires_ugwp_initialize.F90 b/physics/cires_ugwp_initialize.F90 index fbcc1d205..e2f7afd7b 100644 --- a/physics/cires_ugwp_initialize.F90 +++ b/physics/cires_ugwp_initialize.F90 @@ -1,41 +1,11 @@ !=============================== ! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) +! initialization of ugwp_common_v0 +! init gw-solvers (1,2) .. no UFS-funds for (3,4) tests ! init gw-source specifications ! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values - - -! module oro_state - -! integer, parameter :: kind_phys=8 -! integer, parameter :: nvaroro=14 -! real (kind=kind_phys), allocatable :: oro_stat(:, :) -! contains - -! subroutine fill_oro_stat(nx, oc, oa4, clx4, theta, gamm, sigma, elvmax, hprime) - -! real (kind=kind_phys),dimension(nx) :: oc, theta, gamm, sigma, elvmax, hprime -! real(kind=kind_phys),dimension(nx,4) :: oa4, clx4 -! integer :: i -! do i=1, nx -! oro_stat(i,1) = hprime(i) -! oro_stat(i,2) = oc(i) -! oro_stat(i,3:6) = oa4(i,1:4) -! oro_stat(i,7:10) = clx4(i,1:4) -! oro_stat(i,11) = theta(i) -! oro_stat(i,12) = gamm(i) -! oro_stat(i,13) = sigma(i) -! oro_stat(i,14) = elvmax(i) -! enddo -! end subroutine fill_oro_stat - -! end module oro_state - - module ugwp_common +!=============================== + module ugwp_common_v0 ! use machine, only: kind_phys use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & @@ -45,7 +15,7 @@ module ugwp_common real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & rdi = 1.0d0/rd, & - gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & + gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & pi2 = pi + pi, omega1 = pi2/86400.0, & omega2 = omega1+omega1, & @@ -53,7 +23,7 @@ module ugwp_common dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) - end module ugwp_common + end module ugwp_common_v0 ! ! !=================================================== @@ -61,7 +31,7 @@ end module ugwp_common !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) + subroutine init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) implicit none integer :: levs @@ -111,51 +81,20 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) kvg(k) = kvg(k-1) ktg(k) = ktg(k-1) ! - end subroutine init_global_gwdis -! -! - subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none + end subroutine init_global_gwdis_v0 - integer :: levs - real :: pa_rf, tau_rf - real :: dtp - - real :: pmb(levs) - real :: rfdis(levs), rfdist(levs) - integer :: levs_rf - - real :: krf, krfz - integer :: k -! - rfdis(1:levs) = 1.0 - rfdist(1:levs) = 0.0 - levs_rf = levs - if (tau_rf <= 0.0 .or. pa_rf == 0.0) return - - krf = 1.0/(tau_rf*86400.0) - - do k=levs, 1, -1 - if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" - krfz = krf*log(pa_rf/pmb(k)) - rfdis(k) = 1.0/(1.+krfz*dtp) - rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp - levs_rf = k - endif - enddo - - end subroutine rf_damp_init + ! ======================================================================== ! Part 2 - sources ! wave sources ! ======================================================================== ! -! ugwp_oro_init +! ugwpv0_oro_init ! !========================================================================= - module ugwp_oro_init + module ugwpv0_oro_init - use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common_v0, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi implicit none ! @@ -230,7 +169,7 @@ module ugwp_oro_init contains ! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + subroutine init_oro_gws_v0(nwaves, nazdir, nstoch, effac, & lonr, kxw, cdmbgwd ) ! ! @@ -270,195 +209,10 @@ subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & !.................................................................... ! ! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) - end subroutine init_oro_gws -! - - end module ugwp_oro_init -! ========================================================================= -! -! ugwp_conv_init -! -!========================================================================= - module ugwp_conv_init - - implicit none - real :: eff_con ! scale factors for conv GWs - integer :: nwcon ! number of waves - integer :: nazcon ! number of azimuths - integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud - real :: con_dlength - real :: con_cldf - - real, parameter :: cmin = 5 !2.5 - real, parameter :: cmax = 95. !82.5 - real, parameter :: cmid = 22.5 - real, parameter :: cwid = cmid - real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 - real, parameter :: mstar = 6.28e-3/2. ! 2km - real :: dc - - real, allocatable :: ch_conv(:), spf_conv(:) - real, allocatable :: xaz_conv(:), yaz_conv(:) - contains -! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cgwf) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cgwf(2) - real :: kxw, effac - real :: work1 = 0.5 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - con_dlength = pi2*arad/float(lonr) - con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) -! -! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" -! - if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) - if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) - if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) - if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) -! -! we may use different spectral "shapes" -! for example FVS-93 "Desabeius" -! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail -! - do k = 1,nwaves - chk = cmin + (k-1)*dc - tn4 = (mstar*chk)**4 - ch_conv(k) = chk - spf_conv(k) = bns4*chk/(bns4+tn4) - enddo - - snorm = sum(spf_conv) - spf_conv = spf_conv/snorm*1.5 - - call init_nazdir(nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init -!========================================================================= -! -! ugwp_fjet_init -! -!========================================================================= - - module ugwp_fjet_init - implicit none - real :: eff_fj ! scale factors for conv GWs - integer :: nwfj ! number of waves - integer :: nazfj ! number of azimuths - integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet - - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_fjet(:) , spf_fjet(:) - real, allocatable :: xaz_fjet(:), yaz_fjet(:) - contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwfj = nwaves - nazfj = nazdir - nstfj = nstoch - eff_fj = effac - - if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) - if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) - if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) - if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_fjet(k) = chk - spf_fjet(k) = 1.0 - enddo - call init_nazdir(nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init -! -!========================================================================= -! -! - module ugwp_okw_init -!========================================================================= - implicit none - - real :: eff_okw ! scale factors for conv GWs - integer :: nwokw ! number of waves - integer :: nazokw ! number of azimuths - integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_okwp(:), spf_okwp(:) - real, allocatable :: xaz_okwp(:), yaz_okwp(:) - - contains + end subroutine init_oro_gws_v0 ! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwokw = nwaves - nazokw = nazdir - nstokw = nstoch - eff_okw = effac - - if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) - if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) - if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) - if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_okwp(k) = chk - spf_okwp(k) = 1. - enddo - - call init_nazdir(nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init + end module ugwpv0_oro_init !=============================== end of GW sources ! ! init specific gw-solvers (1,2,3,4) @@ -468,7 +222,7 @@ end module ugwp_okw_init ! Part -3 init wave solvers !=============================== - module ugwp_lsatdis_init + module ugwpv0_lsatdis_init implicit none integer :: nwav, nazd @@ -478,7 +232,7 @@ module ugwp_lsatdis_init ! contains - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_lsatdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) implicit none ! @@ -508,14 +262,14 @@ subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb eff = effac endif ! - end subroutine initsolv_lsatdis + end subroutine initsolv_lsatdis_v0 ! - end module ugwp_lsatdis_init + end module ugwpv0_lsatdis_init ! ! - module ugwp_wmsdis_init + module ugwpv0_wmsdis_init - use ugwp_common, only : pi, pi2 + use ugwp_common_v0, only : pi, pi2 implicit none real, parameter :: maxdudt = 250.e-5 @@ -539,8 +293,6 @@ module ugwp_wmsdis_init real, parameter :: zfluxglob= 3.75e-3 real , parameter :: nslope=1 ! the GW sprctral slope at small-m -! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level -! integer, parameter :: ilaunch=klaunch integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum @@ -563,11 +315,8 @@ module ugwp_wmsdis_init real, allocatable :: zcosang(:), zsinang(:) contains !============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_wmsdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) -! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & -! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) -! implicit none ! !input -control for solvers: @@ -680,25 +429,7 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, print * endif - - end subroutine initsolv_wmsdis + end subroutine initsolv_wmsdis_v0 ! -! make a list of all-initilized parameters needed for "gw_solver_wmsdis" -! - - end module ugwp_wmsdis_init -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis - implicit none - end subroutine init_dspdis - - subroutine init_adodis - implicit none - end subroutine init_adodis - + end module ugwpv0_wmsdis_init diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 deleted file mode 100644 index 4258680ea..000000000 --- a/physics/cires_ugwp_initialize_v1.F90 +++ /dev/null @@ -1,805 +0,0 @@ -!=============================== -! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) -! init gw-source specifications -! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values -! -! - - module ugwp_common_v1 -! -! use machine, only : kind_phys -! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & -! rv => con_rv, cpd => con_cp, fv => con_fvirt,& -! arad => con_rerth - implicit none - - real, parameter :: grav =9.81, cpd = 1004. - real, parameter :: rd = 287.0 , rv =461.5 - real, parameter :: grav2 = grav + grav - real, parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav - - real, parameter :: fv = rv/rd - 1.0 - real, parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd - real, parameter :: gor = grav/rd - real, parameter :: gr2 = grav*gor - real, parameter :: grcp = grav*rcpd, gocp = grcp - real, parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - real, parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - - real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi - real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 - - real, parameter :: arad = 6370.e3 -! - real, parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) - real, parameter :: bnv2max = (pi2/30.)*(pi2/30.) - - real, parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 - real, parameter :: omega1 = pi2/86400. - real, parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 - real, parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp - real, parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin - real, parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax - real, parameter :: cdmin = 2.e-2/mkzmax - end module ugwp_common_v1 -! -! -!=================================================== -! -!Part-1 init => wave dissipation + RFriction -! -!=================================================== - subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - pa_rf, tau_rf, me, master) - - - implicit none - integer , intent(in) :: me, master - integer , intent(in) :: levs - real, intent(in) :: con_pi, pa_rf, tau_rf - real, intent(in) :: zkm(levs), pmb(levs) ! in km-Pa - real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion -! -!locals + data -! - integer :: k - real, parameter :: vusurf = 2.e-5 - real, parameter :: musurf = vusurf/1.95 - real, parameter :: hpmol = 8.5 -! - real, parameter :: kzmin = 0.1 - real, parameter :: kturbo = 100. - real, parameter :: zturbo = 130. - real, parameter :: zturw = 30. - real, parameter :: inv_pra = 3. !kt/kv =inv_pr -! - real, parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days - real :: pa_alp = 750. ! super-RF parameters - real :: tau_alp = 10. ! days (750 Pa /10days) -! - real, parameter :: kdrag = 1./86400./30. !parametrization for WAM for FV3GFS SuperRF - real, parameter :: zdrag = 100. - real, parameter :: zgrow = 50. -! - real :: vumol, mumol, keddy, ion_drag - real :: rf_fv3, rtau_fv3, ptop, pih_dlog -! - real :: ae1 ,ae2 - real :: pih - - pih = 0.5*con_pi - - pa_alp = pa_rf - tau_alp = tau_rf - - ptop = pmb(levs) - rtau_fv3 = 1./86400./tau_alp - pih_dlog = pih/log(pa_alp/ptop) - - do k=1, levs - ae1 = -zkm(k)/hpmol - vumol = vusurf*exp(ae1) - mumol = musurf*exp(ae1) - ae2 = -((zkm(k)-zturbo) /zturw)**2 - keddy = kturbo*exp(ae2) - - kvg(k) = vumol + keddy - ktg(k) = mumol + keddy*inv_pra - - krad(k) = alpha -! - ion_drag = kdrag -! - kion(k) = ion_drag! -! add Rayleigh_Super of FV3 for pmb < pa_alp -! - if (pmb(k) .le. pa_alp) then - rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 - krad(k) = krad(k) + rf_fv3 - kion(k) = kion(k) + rf_fv3 - - endif - -! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) - enddo - - k= levs+1 - kion(k) = kion(k-1) - krad(k) = krad(k-1) - kvg(k) = kvg(k-1) - ktg(k) = ktg(k-1) - if (me == master) then - write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ' - do k=1, levs, 1 - write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) - enddo - endif -! - 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) - - end subroutine init_global_gwdis_v1 -! -! - subroutine rf_damp_init_v1(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none - - integer :: levs - real :: pa_rf, tau_rf - real :: dtp - - real :: pmb(levs) - real :: rfdis(levs), rfdist(levs) - integer :: levs_rf - - real :: krf, krfz - integer :: k -! - rfdis(1:levs) = 1.0 - rfdist(1:levs) = 0.0 - levs_rf = levs - if (tau_rf <= 0.0 .or. pa_rf == 0.0) return - - krf = 1.0/(tau_rf*86400.0) - - do k=levs, 1, -1 - if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" - krfz = krf*log(pa_rf/pmb(k)) - rfdis(k) = 1.0/(1.+krfz*dtp) - rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp - levs_rf = k - endif - enddo - - end subroutine rf_damp_init_v1 -! ======================================================================== -! Part 2 - sources -! wave sources -! ======================================================================== -! -! ugwp_oro_init_v1 -! -!========================================================================= - module ugwp_oro_init_v1 - - use ugwp_common_v1, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi - use ugwp_common_v1, only : mkzmin, mkz2min - implicit none -! -! constants and "crirtical" values to run oro-mtb_gw physics -! -! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' -! -! - real, parameter :: hncrit=9000. ! max value in meters for elvmax - real, parameter :: hminmt=50. ! min mtn height (*j*) - real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor -! -! - real, parameter :: minwnd=1.0 ! min wind component (*j*) - real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa - real, parameter :: hpmax=2400.0, hpmin=25.0 - - character(len=8) :: strver = 'gfs_2018' - character(len=8) :: strbase = 'gfs_2018' - real, parameter :: rimin=-10., ric=0.25 - -! - real, parameter :: efmin=0.5, efmax=10.0 - - - real, parameter :: sigma_std=1./100., gamm_std=1.0 - - real, parameter :: frmax=10., frc =1.0, frmin =0.01 -! - - real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 - real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 -! - real, parameter :: rlolev=50000.0 -! - - -! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt - - - - real, parameter :: kxoro=6.28e-3/200. ! - real, parameter :: coro = 0.0 - integer, parameter :: nridge=2 - - real :: cdmb ! scale factors for mtb - real :: cleff ! scale factors for orogw - integer :: nworo ! number of waves - integer :: nazoro ! number of azimuths - integer :: nstoro ! flag for stochastic launch above SG-peak - - integer, parameter :: mdir = 8 - real, parameter :: fdir=.5*mdir/pi - - integer nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ - save nwdir - - real, parameter :: odmin = 0.1, odmax = 10.0 -!------------------------------------------------------------------------------ -! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS -!------------------------------------------------------------------------------ - - integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl - real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters - real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] - real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km -!------------------------------------------------------------------------------ -! - real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm - real, parameter :: fcrit_gfs = 0.7 - real, parameter :: fcrit_mtb = 0.7 - - real, parameter :: zbr_pi = (1.0/2.0)*pi - real, parameter :: zbr_ifs = 0.5*pi - - contains -! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cdmbgwd ) -! -! - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) - ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 - real :: cdmbX - real :: kxw - real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now -!-----------------------------! GFS-setup for cdmb & cleff -! cdmb = 4.0 * (192.0/IMX) -! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) -! - real, parameter :: lonr_refmb = 4.0 * 192.0 - real, parameter :: lonr_refgw = 192.0 - -! copy to "ugwp_oro_init_v1" => nwaves, nazdir, nstoch - - nworo = nwaves - nazoro = nazdir - nstoro = nstoch - - cdmbX = lonr_refmb/float(lonr) - cdmb = cdmbX - if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) - - cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac - -!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac - - if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) -! -!.................................................................... -! higher res => smaller h' ..&.. higher kx -! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) -!.................................................................... -! -! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) - end subroutine init_oro_gws -! - - end module ugwp_oro_init_v1 -! ========================================================================= -! -! ugwp_conv_init_v1 -! -!========================================================================= - module ugwp_conv_init_v1 - - implicit none - real :: eff_con ! scale factors for conv GWs - integer :: nwcon ! number of waves - integer :: nazcon ! number of azimuths - integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud - real :: con_dlength - real :: con_cldf - - real, parameter :: cmin = 5 !2.5 - real, parameter :: cmax = 95. !82.5 - real, parameter :: cmid = 22.5 - real, parameter :: cwid = cmid - real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 - real, parameter :: mstar = 6.28e-3/2. ! 2km - real :: dc - - real, allocatable :: ch_conv(:), spf_conv(:) - real, allocatable :: xaz_conv(:), yaz_conv(:) - contains -! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - con_pi, arad, lonr, kxw, cgwf) - - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi, arad - real :: cgwf(2) - real :: kxw, effac - real :: work1 = 0.5 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - con_dlength = 2.0*con_pi*arad/float(lonr) - con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) -! -! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" -! - if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) - if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) - if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) - if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) -! -! we may use different spectral "shapes" -! for example FVS-93 "Desabeius" -! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail -! - do k = 1,nwaves - chk = cmin + (k-1)*dc - tn4 = (mstar*chk)**4 - ch_conv(k) = chk - spf_conv(k) = bns4*chk/(bns4+tn4) - enddo - - snorm = sum(spf_conv) - spf_conv = spf_conv/snorm*1.5 - - call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init_v1 -!========================================================================= -! -! ugwp_fjet_init_v1 -! -!========================================================================= - - module ugwp_fjet_init_v1 - implicit none - real :: eff_fj ! scale factors for conv GWs - integer :: nwfj ! number of waves - integer :: nazfj ! number of azimuths - integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet - - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_fjet(:) , spf_fjet(:) - real, allocatable :: xaz_fjet(:), yaz_fjet(:) - contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - real :: kxw, effac , chk - - integer :: k - - nwfj = nwaves - nazfj = nazdir - nstfj = nstoch - eff_fj = effac - - if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) - if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) - if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) - if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_fjet(k) = chk - spf_fjet(k) = 1.0 - enddo - call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init_v1 -! -!========================================================================= -! -! - module ugwp_okw_init_v1 -!========================================================================= - implicit none - - real :: eff_okw ! scale factors for conv GWs - integer :: nwokw ! number of waves - integer :: nazokw ! number of azimuths - integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_okwp(:), spf_okwp(:) - real, allocatable :: xaz_okwp(:), yaz_okwp(:) - - contains -! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) - - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - real :: kxw, effac , chk - - integer :: k - - nwokw = nwaves - nazokw = nazdir - nstokw = nstoch - eff_okw = effac - - if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) - if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) - if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) - if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_okwp(k) = chk - spf_okwp(k) = 1. - enddo - - call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init_v1 - -!=============================== end of GW sources -! -! init specific gw-solvers (1,2,3,4) -! - -!=============================== -! Part -3 init wave solvers -!=============================== - - module ugwp_lsatdis_init_v1 - implicit none - - integer :: nwav, nazd - integer :: nst - real :: eff - integer, parameter :: incdim = 4, iazdim = 4 -! - contains - - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - - implicit none -! - integer :: me, master - integer :: nwaves, nazdir - integer :: nstoch - real :: effac - logical :: do_physb - real :: kxw -! -!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces -! are not actibve -! - integer :: inc, jk, jl, iazi, i, j, k - - if( nwaves == 0 .or. nstoch == 1 ) then -! redefine from the default - nwav = incdim - nazd = iazdim - nst = 0 - eff = 1.0 - else -! from input_nml multi-wave spectra - nwav = nwaves - nazd = nazdir - nst = nstoch - eff = effac - endif -! - end subroutine initsolv_lsatdis -! - end module ugwp_lsatdis_init_v1 -! -! - module ugwp_wmsdis_init_v1 - - use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 - use ugwp_common_v1, only : bnv2max, bnv2min, minvel - use ugwp_common_v1, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin - implicit none - - real, parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 - real, parameter :: dked_min =0.01, dked_max=250.0 - - real, parameter :: gptwo=2.0 - - real , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix - real , parameter :: bnfix4 = bnfix2 * bnfix2 - real , parameter :: bnfix3 = bnfix2 * bnfix -! -! make parameter list that will be passed to SOLVER -! -! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level -! integer, parameter :: ilaunch=klaunch - - integer , parameter :: iazidim=4 ! number of azimuths - integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum - real , parameter :: ucrit=cdmin - - real , parameter :: zcimin = 2.5 - real , parameter :: zcimax = 125.0 - real , parameter :: zgam = 0.25 -! -! Verical spectra -! - real , parameter :: pind_wd = 5./3. - real , parameter :: sind_kz = 1. - real , parameter :: tind_kz = 3. - real , parameter :: stind_kz = sind_kz + tind_kz -! -! from kmob_ugwp namelist -! - real :: nslope ! the GW sprctral slope at small-m - real :: lzstar - real :: lzmin - real :: lzmax - real :: lhmet - real :: tamp_mpa !amplitude for GEOS-5/MERRA-2 - real :: tau_min ! min of GW MF 0.25 mPa - integer :: ilaunch - real :: gw_eff - - real :: v_kxw, rv_kxw, v_kxw2 - - - -!=========================================================================== - integer :: nwav, nazd, nst - real :: eff - - real :: zaz_fct, zms - real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) - real, allocatable :: zcosang(:), zsinang(:) - real, allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) - -! -! GW-eddy constants for wave-mode dissipation by background and stability of -! "final" flow after application of GW-effects -! - real, parameter :: iPr_pt = 0.5 - real, parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. - real, parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable - real, parameter :: ric =0.25 - real, parameter :: rimin = -10., prmin = 0.25 - real, parameter :: prmax = 4.0 -! - contains -!============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - -! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & -! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) -! - implicit none -! -!input -control for solvers: -! nwaves, nazdir, nstoch, effac, do_physb, kxw -! -! - integer :: me, master, nwaves, nazdir, nstoch - real :: effac, kxw - logical :: do_physb - real :: dlzmet -! -!locals -! - integer :: inc, jk, jl, iazi -! - real :: zang, zang1, znorm - real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp - real :: fpc, fpc_dc - real :: ae1,ae2 - if( nwaves == 0) then -! -! redefine from the deafault -! - nwav = incdim - nazd = iazidim - nst = 0 - eff = 1.0 - gw_eff = eff - else -! -! from input.nml -! - nwav = nwaves - nazd = nazdir - nst = nstoch - gw_eff = effac - endif - - - v_kxw = pi2/lhmet ; v_kxw2 = v_kxw*v_kxw - rv_kxw = 1./v_kxw - - allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) - allocate ( zcosang(nazd), zsinang(nazd) ) - allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) - - if (me == master) then - print *, 'ugwp_v1: init_gw_wmsdis_control ' -! - print *, 'ugwp_v1: WMS_DIS launch layer ', ilaunch - print *, 'ugwp_v1: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. - print *, 'ugwp_v1: WMS_DIS lhmet in km ' , lhmet*1.e-3 - endif - - zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. - -! -! set up azimuth directions and some trig factors -! -! - zang = pi2 / float(nazd) - -! get normalization factor to ensure that the same amount of momentum -! flux is directed (n,s,e,w) no mater how many azimuths are selected. -! - znorm = 0.0 - do iazi=1, nazd - zang1 = (iazi-1)*zang - zcosang(iazi) = cos(zang1) - zsinang(iazi) = sin(zang1) - znorm = znorm + abs(zcosang(iazi)) - enddo -! zaz_fct = 1.0 - zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums - -! define coordinate transform for "Ch" ....x = 1/c stretching transform -! ----------------------------------------------- -! -! x=1/Cphase transform -! see eq. 28-30 Scinocca 2003. x = 1/c stretching transform -! - zxmax = 1.0 / zcimin - zxmin = 1.0 / zcimax - zxran = zxmax - zxmin - zdx = zxran / real(nwav-1) ! dkz -! - ae1=zxran/zgam - zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. - zx2 = zxmin - zx1 - -! -! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform -! it represents additional "empirical" redistribution of "spectral" mode in C-space -! - zms = pi2 / lzstar - - do inc=1, nwav - ztx = real(inc-1)*zdx+zxmin - ae1 = (ztx-zxmin)/zgam - zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 - zci(inc) = 1.0 /zx ! - zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! - zci4(inc) = (zms*zci(inc))**4 - zci2(inc) = (zms*zci(inc))**2 - zci3(inc) = (zms*zci(inc))**3 - enddo -! -! -! alternatuve lzmax-lzmin -! -! - dlzmet = (lzmax-lzmin)/ real(nwav-1) - do inc=1, nwav - lzmet(inc) = lzmin + (inc-1)*dlzmet - mkzmet(inc) = pi2/lzmet(inc) - zci(inc) =lzmet(inc)/(pi2/bnfix) - zci4(inc) = (zms*zci(inc))**4 - zci2(inc) = (zms*zci(inc))**2 - zci3(inc) = (zms*zci(inc))**3 - - enddo - - zdx = (zci(nwav)-zci(1))/ real(nwav-1) - - - if (me == master) then - print * - print *, 'ugwp_v0: zcimin=' , zcimin - print *, 'ugwp_v0: zcimax=' , zcimax - print *, 'ugwp_v0: zgam= ', zgam - print * - -! print *, ' ugwp_v1 nslope=', nslope - print * - print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) - print *, 'ugwp_v1: zcimax/zci=' , minval(zci) - print *, 'ugwp_v1: cd_crit=', ucrit - print *, 'ugwp_v1: launch_level', ilaunch - print *, ' ugwp_v1 lzstar=', lzstar - print *, ' ugwp_v1 nslope=', nslope - - print * - do inc=1, nwav - zdci(inc) = zdx - if (nslope == 1) fpc = bnfix4*zci(inc)/ (bnfix4+zci4(inc)) - if (nslope == 0) fpc = bnfix3*zci(inc)/ (bnfix3+zci3(inc)) - fpc_dc = fpc * zdci(inc) - write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) - enddo - endif - 111 format( 'wms-zci', i4, 7 (3x, F8.3)) - - end subroutine initsolv_wmsdis -! -! make a list of all-initilized parameters needed for "gw_solver_wmsdis" -! - - end module ugwp_wmsdis_init_v1 -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis_v1 - implicit none - end subroutine init_dspdis_v1 - - subroutine init_adodis_v1 - implicit none - end subroutine init_adodis_v1 - diff --git a/physics/cires_ugwp_module.F90 b/physics/cires_ugwp_module.F90 index 51c297237..620386ead 100644 --- a/physics/cires_ugwp_module.F90 +++ b/physics/cires_ugwp_module.F90 @@ -1,17 +1,12 @@ ! -module cires_ugwp_module +module cires_ugwpv0_module ! ! driver is called after pbl & before chem-parameterizations ! -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! + implicit none logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver @@ -54,7 +49,7 @@ module cires_ugwp_module data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] - integer :: knob_ugwp_version = 0 + integer :: knob_ugwp_version = 0 ! version control had sense under IPD in CCPP=> to SUITES integer :: launch_level = 55 ! namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & @@ -106,16 +101,14 @@ module cires_ugwp_module ! init of cires_ugwp (_init) called from GFS_driver.F90 ! ! ----------------------------------------------------------------------- - subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + subroutine cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & pa_rf_in, tau_rf_in) - use ugwp_oro_init, only : init_oro_gws - use ugwp_conv_init, only : init_conv_gws - use ugwp_fjet_init, only : init_fjet_gws - use ugwp_okw_init, only : init_okw_gws - use ugwp_wmsdis_init, only : initsolv_wmsdis, ilaunch - use ugwp_lsatdis_init, only : initsolv_lsatdis + use ugwpv0_oro_init, only : init_oro_gws_v0 + use ugwpv0_wmsdis_init, only : initsolv_wmsdis_v0, ilaunch + use ugwpv0_lsatdis_init, only : initsolv_lsatdis_v0 + implicit none integer, intent (in) :: me @@ -132,7 +125,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes real, intent (in) :: pa_rf_in, tau_rf_in -! integer, parameter :: logunit = 6 integer :: ios logical :: exists real :: dxsg @@ -155,8 +147,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & read (nlunit, nml = cires_ugwp_nml) close (nlunit) #endif - - ! ilaunch = launch_level @@ -173,13 +163,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! effective kxw - resolution-aware ! dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh -! -! kxw = pi2/dxsg -! -! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff -! - -! allocate(fcor(latr), fcor2(latr) ) ! allocate( kvg(levs+1), ktg(levs+1) ) allocate( krad(levs+1), kion(levs+1) ) @@ -195,50 +178,22 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! ! Part-1 :init_global_gwdis ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) - call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + call init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) + ! -! Part-2 :init_SOURCES_gws +! Part-2 :init_SOURCES_gws -- only orowaves, but ugwp-v0 is based on gwdps.f of EMC ! ! ! call init-solver for "stationary" multi-wave spectra and sub-grid oro ! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + call init_oro_gws_v0( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) ! ! call init-sources for "non-sationary" multi-wave spectra ! do_physb_gwsrcs=.true. - IF (do_physb_gwsrcs) THEN - - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' - if (knob_ugwp_wvspec(4) > 0) then -! okw - call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' - endif - - if (knob_ugwp_wvspec(3) > 0) then -! fronts - call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' - endif - - if (knob_ugwp_wvspec(2) > 0) then -! conv - call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) - if (me == master) & - print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) - - endif - - ENDIF !IF (do_physb_gwsrcs) - !====================== ! Part-3 :init_SOLVERS ! ===================== @@ -247,428 +202,40 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! if (knob_ugwp_solver==1) then ! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_lsatdis_v0(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) endif if (knob_ugwp_solver==2) then - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_wmsdis_v0(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) endif -! -! other solvers not yet tested for fv3gfs -! -!< if (knob_ugwp_solver==3) call init_dspdis -!< if (knob_ugwp_solver==4) call init_adodis -! + !====================== module_is_initialized = .true. - if (me == master) print *, ' VAY-ugwp is initialized ', module_is_initialized - - end subroutine cires_ugwp_mod_init - -! ----------------------------------------------------------------------- -! -! driver of cires_ugwp (_driver) -! called from GFS_physics_driver.F90 -! -! ----------------------------------------------------------------------- -! call cires_ugwp_driver & -! (im, levs, dtp, kdt, me, lprnt, Model%lonr, & -! Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & -! Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & -! Statein, delp_gws, Oro_stat, & -! dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & -! Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & -! Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & -! Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & -! Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & -! Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & -! Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & -! Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & -! Diag%du3dt_ogw, Diag%du3dt_tms ) - - subroutine cires_ugwp_driver & - (im, levs, dtp, kdt, me, lprnt, lonr, & - pa_rf, tau_rf, cdmbgwd, xlat, xlatd, sinlat, coslat, & - ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & - delp, orostat, kpbl, & - dusfc, dvsfc, dudt, dvdt, dtdt, kdis, & - axtot, axo, axc, axf, aytot, ayo, ayc, ayf, & - eps_tot, ekdis, trig_okw, trig_fgf, & - dcheat, precip, cld_klevs, zmtb, scheat, dlength, cldf, & - taus_sso, taus_ogw, tauf_ogw, tauf_ngw, & - ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb, ugw_axlwb, ugw_axtms ) - -! - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd - use ugwp_common, only: omega2 -! -! - use ugwp_okw_init, only : & - eff_okw, nstokw, nwokw, ch_okwp, nazokw, spf_okwp, xaz_okwp, yaz_okwp - use ugwp_conv_init, only : & - eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv - use ugwp_fjet_init, only : & - eff_fj, nstfj, nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet - -! - implicit none -! - - logical :: lprnt - integer :: me, im, levs, kdt, lonr - real(kind_phys) :: dtp - real(kind_phys) :: pa_rf, tau_rf - real(kind_phys) :: cdmbgwd(2) - - integer, intent(in) :: kpbl(im) - real(kind_phys) :: hpbl(im) - real(kind_phys), intent(in) :: orostat(im, 14) - real(kind_phys), intent(in), dimension(im,levs) :: ugrs, vgrs, & - tgrs, qgrs, prsi, prsl, prslk, phii, phil, delp -! - real(kind_phys), dimension(im) :: xlat, xlatd, sinlat, coslat - real(kind_phys), dimension(im, levs) :: trig_okw, trig_fgf - real(kind_phys), dimension(im) :: precip ! precip-n rates and - integer , dimension(im, 3) :: cld_klevs ! indices fo cloud top/bot/? - real(kind_phys), dimension(im, levs) :: dcheat, scheat ! deep and shal conv heat tend. - - - real(kind_phys), dimension(im) :: dlength ! tail-grid box scale in meters - real(kind_phys), dimension(im) :: cldf ! "bizzard" old cgwd-tuning knobs dimensionless -!=================== -! tendency + kdis -!=================== - real(kind_phys), dimension(im, levs) :: dudt, dvdt, dtdt, kdis - real(kind_phys), dimension(im, levs) :: axtot, axo, axc, axf - real(kind_phys), dimension(im, levs) :: aytot, ayo, ayc, ayf - real(kind_phys), dimension(im, levs) :: eps_tot, ekdis - -! - real(kind_phys), dimension(im, levs) :: eds_o, kdis_o - real(kind_phys), dimension(im, levs) :: eds_c, kdis_c - real(kind_phys), dimension(im, levs) :: eds_f, kdis_f - real(kind_phys), dimension(im, levs) :: ax_rf, ay_rf, eps_rf -! -!================================================================================== -! diagnostics for OGW & NGW + SSO effects axmtb, axlwb, axtms -!================================================================================== - real(kind_phys), dimension(im) :: dusfc, dvsfc - real(kind_phys), dimension(im) :: taus_sso, taus_ogw, tauf_ogw, tauf_ngw - real(kind_phys), dimension(im) :: ugw_zmtb, ugw_zlwb, ugw_zogw - real(kind_phys), dimension(im, levs) :: ugw_axmtb,ugw_axlwb, ugw_axtms - real(kind_phys), dimension(im, levs) :: tauz_ogw, tauz_ngw, wtauz - -! -! knob_ugwp_source=[ 1, 1, 1, 0 ] -! oro conv nst imbal-okw -! locals -! - integer :: i, j, k, istype, ido -! -! internal diagnostics for oro-waves, lee waves, and mtb : -! - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw ! GW-launch levels in "meters" -! - real(kind_phys), dimension(im) :: fcor, c2f2 -! -! three sources with different: a) spectra-content/azimuth; b) efficiency ;c) spectral shape -! - real(kind_phys), dimension(im) :: taub_con, taub_fj, taub_okw - integer , dimension(im) :: klev_okw, klev_fj, klev_con - integer , dimension(im) :: if_okw, if_con, if_fj - integer :: nf_okw, nf_con, nf_fj -! - dudt = 0. - dvdt = 0. - dtdt = 0. - kdis = 0. - axo = 0. ; axc = 0. ; axf = 0. - ayo = 0. ; ayc = 0. ; ayf = 0. - eds_o = 0. ; kdis_o = 0. ; eds_f = 0. ; kdis_f = 0. ; eds_c = 0. ; kdis_c = 0. - ax_rf = 0. ; ay_rf = 0. ; eps_rf = 0 - - hpbl(:) = 2000. ! hpbl (1:im) = phil(1:im, kpbl(1:im)) -! - - do i=1, im - fcor(i) = omega2*sinlat(i) - c2f2(i) = fcor(i)*fcor(i)/(kxw*kxw) - enddo - -! i=im -! print *, i, fcor(i), 6.28e-3/kxw, sqrt(c2f2(i)) -! print *, maxval(statein%prsl/statein%tgrs)/287. , ' density ' - -! -! -! What can be computed for ALL types of GWs? => -! "Br-Vi frequency"with "limits" in case of "conv-unstable" layers -! Background dissipation: Molecular + Eddy -! Wind projections may differ from GW-sources/propagation azimuths -! - do istype=1, size(knob_ugwp_source) - - ido = knob_ugwp_source(istype) ! 0 or 1 off or active - - ugwp_azdir = knob_ugwp_azdir(istype) - ugwp_stoch = knob_ugwp_stoch(istype) - ugwp_nws = knob_ugwp_wvspec(istype) - ugwp_effac = knob_ugwp_effac(istype) - -! -! oro-gw effects -! - if (ido == 1 .and. istype ==1 ) then -! -! 1. solve for OGW effects on the mean flow -! 2. all parts of ORO effexra inside: MTB TOFD LeeWB OGW-drag -! - call ugwp_oro(im, levs, dtp, kdt, me, lprnt, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - orostat, hpbl, axo, ayo, eds_o, kdis_o, & - dusfc, dvsfc, dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, & - dusfc_lwb, dvsfc_lwb, zmtb, zlwb, zogw,tauf_ogw,tauz_ogw,& - ugw_axmtb,ugw_axlwb, ugw_axtms) -! -! taus_sso, taus_ogw, tauz_ogw, tauz_ngw, tauf_ogw, tauf_ngw, & -! ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb,ugw_axlwb, ugw_axtms -! collect column-integrated "dusfc, dvsfc" only for oro-waves -! - taus_sso = dusfc_mb + dusfc_lwb + dusfc_ogw - taus_ogw = dusfc_ogw - ugw_zmtb = zmtb - ugw_zlwb = zlwb - ugw_zogw = zogw -! tauz_ogw/tauf_ogw => output -! ugwp_azdir, ugwp_stoch, ugwp_nws ..... "multi-wave + stochastic" -! -! stationary gw-mode ch=0, with "gw_solver_linsat" -! compute column-integrated "dusfc, dvsfc" only for oro-waves -! - dudt = dudt + axo * ugwp_effac - dvdt = dvdt + ayo * ugwp_effac - dtdt = dtdt + eds_o * ugwp_effac - kdis = kdis + kdis_o* ugwp_effac -! print *, ' ido istype ORO=1 ', ido, istype, ' ugwp_oro as a solver ' - endif - - if (ido == 1 .and. istype ==2 ) then -! -! convective gw effects -! -! 1. specify spectra + forcing nstcon, nwcon, ch_conv, nazcon, spf_conv -! - call get_spectra_tau_convgw & - (nwcon, im, levs, dcheat, scheat, precip, cld_klevs, & - xlatd, sinlat, coslat, taub_con, klev_con, if_con, nf_con) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_con > 0) then - - klev_con(:) = 52 ! ~5 km -! -!eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv, & - fcor, c2f2, ugrs, vgrs, tgrs, qgrs, prsi, delp, & - prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) - - - if (knob_ugwp_solver == 2) then -! print *, ' before CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) -! print *, ' after ido istype CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - endif - - dudt = dudt + axc * ugwp_effac - dvdt = dvdt + ayc * ugwp_effac - dtdt = dtdt + eds_c * ugwp_effac - kdis = kdis + kdis_c * ugwp_effac - - tauz_ngw = wtauz - - endif - - endif - - if (ido == 1 .and. istype ==3 ) then -! -! nonstationary gw effects -! -! 1. specify spectra + forcing -! - call get_spectra_tau_nstgw (nwfj, im, levs, & - trig_fgf, xlatd, sinlat, coslat, taub_fj, klev_fj, if_fj, nf_fj) -! -! 2. solve for GW effects on the mean flow -! - print *, ' tau_nstgw nf_fj-GW triggers ', nf_fj, ' ugwp_solver = ', knob_ugwp_solver - if ( nf_fj > 0) then - - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - print *, ' ido istype for FJ 1-4 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - - endif - endif -! print *, ' ido istype for okw 1-4 ', ido, istype - if (ido == 1 .and. istype == 4 ) then -! -! nonstationary gw effects due to both "convection +fronts/jets " = imbalance of rs-flow -! -! 1. specify spectra + forcing -! - call get_spectra_tau_okw (nwokw, im, levs,& - trig_okw, xlatd, sinlat, coslat, taub_okw, klev_okw, if_okw, nf_okw) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_okw > 0) then -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - endif - endif -! -! broad gw-spectra -! - 356 continue - enddo -! -! gw-diag only -! - axtot = dudt - aytot = dvdt - eps_tot = dtdt - -! -! optional rf-damping -! - if (do_rfdamp) then -! -! - call rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, ugrs, vgrs, ax_rf, ay_rf, eps_rf) -! -! gw-diag only + rf-damping ..... now orchestrate it with FV3-dycore RF-damping -! - do k=levs_rf, levs - - dudt(:,k) = dudt(:,k) + ax_rf(:,k) - dvdt(:,k) = dvdt(:,k) + ay_rf(:,k) - dtdt(:,k) = dtdt(:,k) + eps_rf(:,k) - - enddo - - endif -!================================================================================ -! To update U-V-T STATE by [dudt dvdt dtdt kdis+rf] => Solve 3-diag VD-equation -!================================================================================ -! to do for fv3wam=> -! joint eddy+molecular viscosity/conductivity/diffusion -! requires "dqdt" + dudt_vis, dvdt_vis. dtdt_cond - -! print *, ' cires_ugwp_driver +++++++++++++++++ ' -! - end subroutine cires_ugwp_driver - - -!============================================= - - - subroutine cires_ugwp_advance -!----------------------------------------------------------------------- -! -! options for the day-to-day variable sources/spectra + diagnostics -! for stochastic "triggers" -! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields -! or use for stochastic GWP-sources "memory" -!----------------------------------------------------------------------- - implicit none -! -! update sources -! a) physics-based triggers for multi-wave -! b) stochastic-based spectra and amplitudes -! c) use "memory" on GW-spectra from previous time-step -! d) update "background" GW dissipation as needed -! - end subroutine cires_ugwp_advance - + end subroutine cires_ugwpv0_mod_init ! ! ----------------------------------------------------------------------- ! finalize of cires_ugwp (_finalize) ! ----------------------------------------------------------------------- - - subroutine cires_ugwp_mod_finalize + subroutine cires_ugwpv0_mod_finalize ! ! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" ! before "end" of the FV3GFS ! implicit none ! -! deallocate arrays employed in: -! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! deallocate arrays employed in V0 ! deallocate( kvg, ktg ) deallocate( krad, kion ) deallocate( zkm, pmb ) deallocate( rfdis, rfdist) - end subroutine cires_ugwp_mod_finalize + end subroutine cires_ugwpv0_mod_finalize ! - end module cires_ugwp_module + end module cires_ugwpv0_module diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 deleted file mode 100644 index fd41d8175..000000000 --- a/physics/cires_ugwp_module_v1.F90 +++ /dev/null @@ -1,672 +0,0 @@ - -module cires_ugwp_module_v1 - -! -! driver is called after pbl & before chem-parameterizations -! it uses ugwp_common (like phys_cons) and some module-param od solvers/sources init-modules -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! - use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 - implicit none - logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction - character(len=8) :: strsolver='pss-1986' - logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources - logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver - integer, parameter :: idebug_gwrms=1 ! control for diag computaions pw wind-temp GW-rms and MF fluxs - logical, parameter :: do_adjoro = .false. - real, parameter :: max_kdis = 250. ! 400 m2/s - real, parameter :: max_axyz = 250.e-5 ! 400 m/s/day - real, parameter :: max_eps = max_kdis*4.e-7 ! ~16 K/day max_kdis*BN2/cp - real, parameter :: maxdudt = max_axyz - real, parameter :: maxdtdt = max_eps - real, parameter :: dked_min = 0.01 - real, parameter :: dked_max = max_kdis - - - real, parameter :: hps = hpscale - real, parameter :: hpskm = hps/1000. -! - - real, parameter :: ricrit = 0.25 - real, parameter :: frcrit = 0.50 - real, parameter :: linsat = 1.00 - real, parameter :: linsat2 = linsat*linsat -! -! integer :: curday_ugwp ! yyyymmdd 20150101 -! integer :: ddd_ugwp ! ddd of year from 1-366 - - integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) - integer, dimension(4) :: knob_ugwp_source=(/1,0,1,0/) ! [1,0,1,1] - (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_wvspec=(/1,32,32,32/) ! number of waves for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_azdir=(/2,4,4,4/) ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_stoch=(/0,0,0,0/) ! 0 - deterministic ; 1 - stochastic - real, dimension(4) :: knob_ugwp_effac=(/1.,1.,1.,1./) ! efficiency factors for- (oro, fronts, conv, imbf-owp] - - integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag - integer :: knob_ugwp_doheat=1 ! 1 -gwheat - integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing - integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw - integer :: knob_ugwp_nslope = 1 ! spectral"growth" S-slope of GW-energy spectra mkz^S - - real :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs - real :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra - real :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km - real :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra - real :: knob_ugwp_taumin = 0.25e-3 - real :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) - real :: knob_ugwp_lhmet = 200.e3 ! 200 km -! - real :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes -! -! tune-ups for qbo -! - real :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs - real :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians - real :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing - real :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO - real :: knob_ugwp_qbotau = 10. ! relaxation time scale in days - real :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing - real :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing - character(len=8) :: knob_ugwp_orosolv='pss-1986' - - character(len=255) :: ugwp_qbofile = 'qbo_zmf_2009_2018.nc' - character(len=255) :: ugwp_taufile = 'ugwp_limb_tau.nc' - -! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! -! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' -! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' - -! integer, parameter :: ny_tab=73, nt_tab=14 -! real, parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. -! real :: days_tab(nt_tab), lat_tab(ny_tab) -! real :: abmf_tab(ny_tab,nt_tab) - - integer :: ugwp_azdir - integer :: ugwp_stoch - - integer :: ugwp_src - integer :: ugwp_nws - real :: ugwp_effac - -! - integer :: knob_ugwp_version = 0 - integer :: launch_level = 55 -! - namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & - knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & - knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & - knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & - knob_ugwp_qbolev, knob_ugwp_qbosin, knob_ugwp_qbotav, knob_ugwp_qboamp, knob_ugwp_qbotau, & - knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_orosolv - -!&cires_ugwp_nml -! knob_ugwp_solver=2 -! knob_ugwp_source=1,1,1,0 -! knob_ugwp_wvspec=1,32,32,32 -! knob_ugwp_azdir =2, 4, 4,4 -! knob_ugwp_stoch =0, 0, 0,0 -! knob_ugwp_effac=1, 1, 1,1 -! knob_ugwp_doaxyz=1 -! knob_ugwp_doheat=1 -! knob_ugwp_dokdis=0 -! knob_ugwp_ndx4lh=4 -!/ -! -! allocatable arrays, initilized during "cires_ugwp_init" & -! released during "cires_ugwp_finalize" -! - real, allocatable :: kvg(:), ktg(:), krad(:), kion(:) - real, allocatable :: zkm(:), pmb(:) - real, allocatable :: rfdis(:), rfdist(:) - integer :: levs_rf - real :: pa_rf, tau_rf -! -! tabulated GW-sources -! - integer :: ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t - real, allocatable :: ugwp_taulat(:), ugwp_qbolat(:) - real, allocatable :: tau_limb(:,:), days_limb(:) - real, allocatable :: uzmf_merra(:,:,:), days_merra(:), pmb127(:) - real, allocatable :: uqboe(:,:) - real, allocatable :: days_y4ddd(:), zkm127(:) - real, allocatable :: tau_qbo(:), stau_qbo(:) - integer,allocatable :: days_y4md(:) - real, allocatable :: vert_qbo(:) - -! -! limiters -! - real, parameter :: latqbo =20., widqbo=15., taurel = 21600. - integer, parameter :: kz2 = 127-7, kz1= 127-49, kz5=5 ! 64km - 18km -! - -!====================================================================== - real, parameter :: F_coriol=1 ! Coriolis effects - real, parameter :: F_nonhyd=1 ! Nonhydrostatic waves - real, parameter :: F_kds =0 ! Eddy mixing due to GW-unstable below - real, parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw - real, parameter :: iPr_turb =1./3., iPr_mol =1.95 - real, parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 - real, parameter :: khp = 0.287*rhp1 ! R/Cp/Hp - real, parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model - - contains -! -! ----------------------------------------------------------------------- -! -! init of cires_ugwp (_init) called from CCPP cap file -! -! ----------------------------------------------------------------------- - - - - subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, con_pi, & - con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, & - cgwf, pa_rf_in, tau_rf_in, errmsg, errflg) -! -! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 -! - use netcdf - use ugwp_oro_init_v1, only : init_oro_gws - use ugwp_conv_init_v1, only : init_conv_gws - use ugwp_fjet_init_v1, only : init_fjet_gws - use ugwp_okw_init_v1, only : init_okw_gws - use ugwp_wmsdis_init_v1, only : initsolv_wmsdis - - use ugwp_lsatdis_init_v1, only : initsolv_lsatdis - - - use ugwp_wmsdis_init_v1, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar - use ugwp_wmsdis_init_v1, only : tau_min, tamp_mpa - implicit none - - integer, intent (in) :: me - integer, intent (in) :: master - integer, intent (in) :: nlunit - integer, intent (in) :: logunit - integer, intent (in) :: lonr - integer, intent (in) :: levs - integer, intent (in) :: latr - integer, intent (in) :: jdat_gfs(8) - real, intent (in) :: ak(levs+1), bk(levs+1), pref - real, intent (in) :: dtp - real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW dims(2) !!! - real, intent (in) :: pa_rf_in, tau_rf_in, con_pi, con_rerth - - character(len=64), intent (in) :: fn_nml2 - character(len=64), parameter :: fn_nml='input.nml' - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! character, intent (in) :: input_nml_file -! integer, parameter :: logunit = 6 - integer :: ios - logical :: exists - real :: dxsg - - integer :: ncid, iernc, vid, dimid, status - integer :: k - integer :: ddd_ugwp, curday_ugwp - real, dimension(6) :: avqbo = (/0.05, 0.1, 0.25, 0.5, 0.75, 0.95/) -! - if (me == master) print *, trim (fn_nml), ' GW-namelist file ' - inquire (file =trim (fn_nml) , exist = exists) -! - if (.not. exists) then - if (me == master) & - write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' - else - open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = cires_ugwp_nml) - close (nlunit) -! - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - - strsolver= knob_ugwp_orosolv - pa_rf = pa_rf_in - tau_rf = tau_rf_in - - curday_ugwp = jdat_gfs(1)*10000 + jdat_gfs(2)*100 +jdat_gfs(3) - call calendar_ugwp(jdat_gfs(1), jdat_gfs(2), jdat_gfs(3), ddd_ugwp) - -! write version number and namelist to log file - if (me == master) then - write (logunit, *) " ================================================================== " - write (logunit, *) "cires_ugwp_namelist_extended_v1" - write (logunit, nml = cires_ugwp_nml) - write (logunit, *) " ================================================================== " - - write (6, *) " ================================================================== " - write (6, *) "cires_ugwp_namelist_extended_v1" - write (6, nml = cires_ugwp_nml) - write (6, *) " ================================================================== " - write (6, *) "calendar_ugwp ddd_ugwp=", ddd_ugwp - write (6, *) "calendar_ugwp curday_ugwp=", curday_ugwp - write (6, *) " ================================================================== " - write (6, *) ddd_ugwp, ' jdat_gfs ddd of year ' - endif -! -! effective kxw - resolution-aware -! - dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh - kxw = pi2/knob_ugwp_lhmet -! -! kxw = pi2/dxsg -! -! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff -! - -! allocate(fcor(latr), fcor2(latr) ) -! - allocate( kvg(levs+1), ktg(levs+1) ) - allocate( krad(levs+1), kion(levs+1) ) - allocate( zkm(levs), pmb(levs) ) - allocate( rfdis(levs), rfdist(levs) ) - - allocate (vert_qbo(levs)) - -! -! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 -! - - do k=1, levs - pmb(k) = 1.e0*(ak(k) + pref*bk(k)) ! Pa -unit Pref = 1.e5, pmb = Pa - zkm(k) = -hpskm*alog(pmb(k)/pref) - enddo - vert_qbo(1:levs) = 0. - - do k=kz1, kz2 - vert_qbo(k)=1. - if (k.le.(kz1+kz5)) vert_qbo(k) = avqbo(k+1-kz1) - if (k.ge.(kz2-kz5)) vert_qbo(k) = avqbo(kz2+1-k) - if (me == master) print *, 'vertqbo', vert_qbo(k), zkm(k) - enddo - -! -! find ilaunch -! - - do k=levs, 1, -1 - if (pmb(k) .gt. knob_ugwp_palaunch ) exit - enddo - - launch_level = max(k-1, 5) ! above 5-layers from the surface - -! -! Part-1 :init_global_gwdis_v1 -! - call init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - pa_rf, tau_rf, me, master) - call rf_damp_init_v1 (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) -! -! Part-2 :init_SOURCES_gws -! - -! -! call init-solver for "stationary" multi-wave spectra and sub-grid oro -! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & - knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) -! -! call init-sources for "non-sationary" multi-wave spectra -! - do_physb_gwsrcs=.true. - - IF (do_physb_gwsrcs) THEN - - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_v1 ' - if (knob_ugwp_wvspec(4) > 0) then -! okw - call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' - endif - - if (knob_ugwp_wvspec(3) > 0) then -! fronts - call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' - endif - - if (knob_ugwp_wvspec(2) > 0) then -! conv - call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), & - con_pi, con_rerth, lonr, kxw, cgwf ) - if (me == master) & - print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) - - endif - - ENDIF !IF (do_physb_gwsrcs) -! -! -! Tabulated sources -! -! goto 121 - - iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) - - if(iernc.ne.0) then - write(errmsg,'(*(a))') "Cannot open file_limb_tab data-file ", & - trim(ugwp_taufile) - errflg = 1 - return - else - - - status = nf90_inq_dimid(ncid, "lat", DimID) -! if (status /= nf90_noerr) call handle_err(status) -! - status = nf90_inquire_dimension(ncid, DimID, len =ntau_d1y ) - - status = nf90_inq_dimid(ncid, "days", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) - if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd-tlimb ' - allocate (ugwp_taulat(ntau_d1y ), days_limb(ntau_d2t)) - allocate ( tau_limb (ntau_d1y, ntau_d2t )) - - iernc=nf90_inq_varid( ncid, 'DAYS', vid ) - iernc= nf90_get_var( ncid, vid, days_limb) - iernc=nf90_inq_varid( ncid, 'LATS', vid ) - iernc= nf90_get_var( ncid, vid, ugwp_taulat) - iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) - iernc= nf90_get_var( ncid, vid, tau_limb) - - iernc=nf90_close(ncid) - - endif -! - iernc=NF90_OPEN(trim(ugwp_qbofile), nf90_nowrite, ncid) - - if(iernc.ne.0) then - write(errmsg,'(*(a))') "Cannot open qbofile data-file ", & - trim(ugwp_qbofile) - errflg = 1 - return - else - - status = nf90_inq_dimid(ncid, "lat", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d1y ) - status = nf90_inq_dimid(ncid, "lev", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d2z) - status = nf90_inq_dimid(ncid, "days", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d3t ) - if (me == master) print *, nqbo_d1y, nqbo_d2z, nqbo_d3t, ' dims tauqbo ' - allocate (ugwp_qbolat(nqbo_d1y ), days_merra(nqbo_d3t) ) - allocate (zkm127(nqbo_d2z), pmb127(nqbo_d2z)) - allocate ( uzmf_merra (nqbo_d1y, nqbo_d2z, nqbo_d3t )) - allocate ( uqboe (nqbo_d2z, nqbo_d3t )) - allocate (days_y4ddd(nqbo_d3t), days_y4md(nqbo_d3t) ) - allocate (tau_qbo(nqbo_d3t), stau_qbo(nqbo_d3t) ) - - iernc=nf90_inq_varid( ncid, 'DAYS', vid ) - iernc= nf90_get_var( ncid, vid, days_merra) - - iernc=nf90_inq_varid( ncid, 'Y4MD', vid ) - iernc= nf90_get_var( ncid, vid, days_y4md) - - iernc=nf90_inq_varid( ncid, 'Y4DDD', vid ) - iernc= nf90_get_var( ncid, vid, days_y4ddd) - - iernc=nf90_inq_varid( ncid, 'LATS', vid ) - iernc= nf90_get_var( ncid, vid, ugwp_qbolat) - - iernc=nf90_inq_varid( ncid, 'LEVS', vid ) - iernc= nf90_get_var( ncid, vid, zkm127) - - - iernc=nf90_inq_varid( ncid, 'UQBO', vid ) - iernc= nf90_get_var( ncid, vid, uzmf_merra) - - iernc=nf90_inq_varid( ncid, 'TAUQBO', vid ) - iernc= nf90_get_var( ncid, vid, tau_qbo) - - iernc=nf90_inq_varid( ncid, 'STAUQBO', vid ) - iernc= nf90_get_var( ncid, vid, stau_qbo) - iernc=nf90_inq_varid( ncid, 'UQBOE', vid ) - iernc= nf90_get_var( ncid, vid, uqboe) - iernc=nf90_close(ncid) - endif - - if (me == master) then - print * - print *, ' ugwp_tabulated files input ' - print *, ' ugwp_taulat ', ugwp_taulat - print *, ' days ', days_limb - print *, ' TAU-limb ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 - print *, ' TAU-qbo ', maxval(stau_qbo)*1.e3, minval(stau_qbo)*1.e3 - print *, ' YMD-qbo ', maxval(days_y4md), minval(days_y4md) - print *, ' YDDD-qbo ', maxval(days_y4ddd), minval(days_y4ddd) - print *, ' uzmf_merra ',maxval(uzmf_merra), minval(uzmf_merra) - print *, ' uEq_merra ',maxval(uqboe), minval(uqboe) - print * - endif - -! -121 continue -! endif ! tabulated sources SABER/HIRDLS/QBO - -!====================== -! Part-3 :init_SOLVERS -! ===================== -! -! call init-solvers for "broad" non-stationary multi-wave spectra -! - if (knob_ugwp_solver==1) then -! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) - endif - if (knob_ugwp_solver==2) then -! -! re-assign from namelists -! - nslope = knob_ugwp_nslope ! the GW sprctral slope at small-m - lzstar = knob_ugwp_lzstar - lzmax = knob_ugwp_lzmax - lzmin = knob_ugwp_lzmin - lhmet = knob_ugwp_lhmet - tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 - tau_min =knob_ugwp_taumin ! min of GW MF 0.25 mPa - ilaunch = launch_level - kxw = pi2/lhmet - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) - endif -! -! other solvers not yet tested for fv3gfs -! -!< if (knob_ugwp_solver==3) call init_dspdis -!< if (knob_ugwp_solver==4) call init_adodis -! - -!====================== - module_is_initialized = .true. - if (me == master) print *, ' CIRES-ugwp-V1 is initialized ', module_is_initialized - - end subroutine cires_ugwp_init_v1 - - -!============================================= - - - subroutine cires_ugwp_advance -!----------------------------------------------------------------------- -! -! options for the day-to-day variable sources/spectra + diagnostics -! for stochastic "triggers" -! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields -! or use for stochastic GWP-sources "memory" -!----------------------------------------------------------------------- - implicit none -! -! update sources -! a) physics-based triggers for multi-wave -! b) stochastic-based spectra and amplitudes -! c) use "memory" on GW-spectra from previous time-step -! d) update "background" GW dissipation as needed -! - end subroutine cires_ugwp_advance - -! -! ----------------------------------------------------------------------- -! finalize of cires_ugwp (_finalize) -! ----------------------------------------------------------------------- - - - subroutine cires_ugwp_finalize -! -! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" -! before "end" of the FV3GFS -! - implicit none -! -! deallocate arrays employed in: -! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init -! - deallocate( kvg, ktg ) - deallocate( krad, kion ) - deallocate( zkm, pmb ) - deallocate( rfdis, rfdist) - deallocate(ugwp_taulat, ugwp_qbolat) - deallocate(tau_limb, uzmf_merra) - deallocate(days_limb, days_merra, pmb127) - - end subroutine cires_ugwp_finalize - -! -! -! -! - subroutine calendar_ugwp(yr, mm, dd, ddd_ugwp) -! -! computes day of year to get tau_limb forcing written with 1-day precision -! - implicit none - integer, intent(in) :: yr, mm, dd - integer :: ddd_ugwp - - integer :: iw3jdn - integer :: jd1, jddd - jd1 = iw3jdn(yr,1,1) - jddd = iw3jdn(yr,mm,dd) - ddd_ugwp = jddd-jd1+1 - - end subroutine calendar_ugwp - - - subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau, & - j1_qbo,j2_qbo, w1_j1qbo, w2_j2qbo, dexp_latqbo ) - - implicit none -! -! ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t -! ugwp_taulat(:), ugwp_qbolat(:), ugwp_merlat(:) -! - integer :: npts, me, master - integer, dimension(npts) :: j1_tau,j2_tau, j1_qbo, j2_qbo - real , dimension(npts) :: dlat, w1_j1tau, w2_j2tau, w1_j1qbo, w2_j2qbo - real , dimension(npts) :: dexp_latqbo - real :: widqbo2, xabs -! - integer i,j, j1, j2 -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - do j=1,npts - j2_qbo(j) = nqbo_d1y - do i=1, nqbo_d1y - if (dlat(j) < ugwp_qbolat(i)) then - j2_qbo(j) = i - exit - endif - enddo - - - j2_qbo(j) = min(j2_qbo(j),nqbo_d1y) - j1_qbo(j) = max(j2_qbo(j)-1,1) - - if (j1_qbo(j) /= j2_qbo(j) ) then - w2_j2qbo(j) = (dlat(j) - ugwp_qbolat(j1_qbo(j))) & - / (ugwp_qbolat(j2_qbo(j))-ugwp_qbolat(j1_qbo(j))) - - else - w2_j2qbo(j) = 1.0 - endif - w1_j1qbo(j) = 1.0 - w2_j2qbo(j) - -! - enddo -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - do j=1,npts - j2_tau(j) = ntau_d1y - do i=1,ntau_d1y - if (dlat(j) < ugwp_taulat(i)) then - j2_tau(j) = i - exit - endif - enddo - - - j2_tau(j) = min(j2_tau(j),ntau_d1y) - j1_tau(j) = max(j2_tau(j)-1,1) - - if (j1_tau(j) /= j2_tau(j) ) then - w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & - / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) - - else - w2_j2tau(j) = 1.0 - endif - w1_j1tau(j) = 1.0 - w2_j2tau(j) - - enddo - widqbo2 =1./widqbo/widqbo - do j=1,npts - dexp_latqbo(j) =0. - xabs =abs(dlat(j)) - if (xabs .le. latqbo) then - dexp_latqbo(j) = exp(-xabs*xabs*widqbo2) - if (xabs .le. 4.0 ) dexp_latqbo(j) =1. -! print *, ' indx_ugwp dexp=', dexp_latqbo(j), nint(dlat(j)) - endif - enddo - - if (me == master ) then -222 format( 2x, 'vay-wqbo', I4, 5(2x, F10.3)) -223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) - print *, 'vay_indx_ugwp ', size(dlat), ' npts ', npts - do j=1,npts - j1 = j1_tau(j) - j2 = j2_tau(j) - write(6,223) j, ugwp_taulat(j1), dlat(j), ugwp_taulat(j2), w2_j2tau(j), w1_j1tau(j) - enddo - print * - do j=1,npts - j1 = j1_qbo(j) - j2 = j2_qbo(j) - write(6,222) j, ugwp_qbolat(j1), dlat(j), ugwp_qbolat(j2), w2_j2qbo(j), w1_j1qbo(j) - enddo - endif - end subroutine cires_indx_ugwp - -! - end module cires_ugwp_module_v1 - diff --git a/physics/cires_ugwp_ngw_utils.F90 b/physics/cires_ugwp_ngw_utils.F90 deleted file mode 100644 index 4b2a19884..000000000 --- a/physics/cires_ugwp_ngw_utils.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module cires_ugwp_ngw_utils - - -contains - - - subroutine tau_limb_advance(me, master, im, levs, ddd, curdate, & - j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) - - - - - use machine, only : kind_phys - - use cires_ugwp_module_v1, only : ntau_d1y, ntau_d2t - use cires_ugwp_module_v1, only : ugwp_taulat, days_limb, tau_limb - -! use cires_ugwp_module, only : ugwp_qbolat, days_merra, pmb127, days_y4md, days_y4ddd -! use cires_ugwp_module, only : tau_qbo, stau_qbo, uqboe, u2 => uzmf_merra - - implicit none - - integer, intent(in) :: me, master, im, levs, ddd, curdate, kdt - integer, intent(in), dimension(im) :: j1_tau, j2_tau - - real , intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau - - real, intent(out) :: tau_sat(im) - - integer :: i, j1, j2, k, it1, it2, iday - real :: tem, tx1, tx2, w1, w2, day2, day1, ddx - integer :: yr1, yr2 -! - integer :: iqbo1=1 -! - - - - it1 = 2 - do iday=1, ntau_d2t - if (float(ddd) .lt. days_limb(iday) ) then - it2 = iday - exit - endif - enddo - it2 = min(it2,ntau_d2t) - it1 = max(it2-1,1) - if (it2 > ntau_d2t ) then - print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t - stop - endif - w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) - w1 = 1.0-w2 - do i=1, im - j1 = j1_tau(i) - j2 = j2_tau(i) - tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) - tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) - tau_sat(i) = tx1*w1 + w2*tx2 - enddo - - if (me == master ) then - print*, maxval(tau_limb), minval(tau_limb), ' tau_limb ' - print*, ntau_d2t - print*, days_limb(1) , days_limb(ntau_d2t) , ddd, ' days-taulimb ' - print*, 'curdate ', curdate - print*, maxval(tau_sat), minval(tau_sat), ' tau_sat_fv3 ' - endif - return - - end subroutine tau_limb_advance - -end module cires_ugwp_ngw_utils diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 deleted file mode 100644 index fd692a825..000000000 --- a/physics/cires_ugwp_orolm97_v1.F90 +++ /dev/null @@ -1,1008 +0,0 @@ -module cires_ugwp_orolm97_v1 - - -contains - - - - subroutine gwdps_oro_v1(im, km, imx, do_tofd, & - pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & - prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & - oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, & - grav, con_omega, rd, cpd, rv, pi, arad, fv, sgh30, & - dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & - cdmbgwd, me, master, rdxzb, & - zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - dudt_mtb, dudt_ogw, dudt_tms) -!---------------------------------------- -! ugwp_v1: gwdps_oro_v1 following recent updates of Lott & Miller 1997 -! eventually will be replaced with more "advanced"LLWB -! and multi-wave solver that produce competitive FV3GFS-skills -! -! computation of kref for ogw + coorde diagnostics -! all constants/parameters inside cires_ugwp_initialize.f90 -!---------------------------------------- - - use machine , only : kind_phys - use ugwp_common_v1, only : dw2min, velmin - - use ugwp_oro_init_v1, only : rimin, ric, efmin, efmax , & - hpmax, hpmin, sigfaci => sigfac , & - dpmin, minwnd, hminmt, hncrit , & - rlolev, gmax, veleps, factop , & - frc, ce, ceofrc, frmax, cg, & - fdir, mdir, nwdir, & - cdmb, cleff, fcrit_gfs, fcrit_mtb, & - n_tofd, ze_tofd, ztop_tofd - - use cires_ugwp_module_v1, only : kxw, max_kdis, max_axyz - - use cires_orowam2017, only : oro_wam_2017 - - use cires_vert_orodis_v1, only : ugwp_tofd1d - - -! use sso_coorde, only : pgwd, pgwd4 -!---------------------------------------- - implicit none - real(kind=kind_phys), parameter :: pgwd=1, pgwd4= pgwd - real(kind=kind_phys), parameter :: sigfac = 3, sigfacs = 0.5 - character(len=8) :: strsolver='pss-1986' ! current operational solver or 'wam-2017' - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. - logical, parameter :: do_adjoro = .false. -!---------------------------------------- - - integer, intent(in) :: im, km, imx, kdt - integer, intent(in) :: me, master - logical, intent(in) :: do_tofd - - - - integer, intent(in) :: kpbl(im) ! index for the pbl top layer! - real(kind=kind_phys), intent(in) :: dtp ! time step - real(kind=kind_phys), intent(in) :: cdmbgwd(2) - - real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & - clx4(im,4), theta(im), sigmad(im), & - gammad(im), elvmaxd(im) - - real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, & - pi, arad, fv - real(kind=kind_phys), intent(in) :: sgh30(im) - real(kind=kind_phys), intent(in), dimension(im,km) :: & - u1, v1, t1, q1,del, prsl, prslk, zmet - - real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti - real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) - real(kind=kind_phys), intent(in) :: sparea(im) - -! -!output -phys-tend - real(kind=kind_phys),dimension(im,km),intent(out) :: & - pdvdt, pdudt, pkdis, pdtdt -! output - diag-coorde - real(kind=kind_phys),dimension(im,km),intent(out) :: & - dudt_mtb, dudt_ogw, dudt_tms -! - real(kind=kind_phys),dimension(im) :: rdxzb, zmtb, zogw , & - tau_ogw, tau_mtb, tau_tofd, dusfc, dvsfc - -! -!--------------------------------------------------------------------- -! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 -! 4.*gamma*b_ell*b_ell >= shilmin -! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min -! gamma_min = 1/4*shilmin/sso_min/sso_min -!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 -! 192: cdmbgwd = 0.5, 2.5 -! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km -! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin -!--------------------------------------------------------------------- -! -! locals SSO -! - real(kind=kind_phys) :: vsigma(im), vgamma(im) - - real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk - real(kind=kind_phys) :: shilmin, sgrmax, sgrmin - real(kind=kind_phys) :: belpmin, dsmin, dsmax -! real(kind=kind_phys) :: arhills(im) ! not used why do we need? - real(kind=kind_phys) :: xlingfs - -! -! locals mean flow ...etc -! - real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro - real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco -!mtb - real(kind=kind_phys), dimension(im) :: oa, clx , sigma, gamma, & - elvmax, wk - real(kind=kind_phys), dimension(im) :: pe, ek, up - - real(kind=kind_phys), dimension(im,km) :: db, ang, uds - - real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr - real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 - real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem -! -! tofd -! some constants now in "use ugwp_oro_init" + "use ugwp_common" -! -!================== - real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf - real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 - real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 - real(kind=kind_phys), dimension(km) :: up1, vp1, zpm - - real(kind=kind_phys),dimension(im, km) :: axtms, aytms -! -! ogw -! - logical icrilv(im) -! - real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & - roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 -! - real(kind=kind_phys) :: taup(im,km+1), taud(im,km) - real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis - - integer, dimension(im) :: kref, idxzb, ipt, kreflm, iwklm, iwk, izlow - -! -!check what we need -! - real(kind=kind_phys) :: bnv, fr, ri_gw, brvf - real(kind=kind_phys) :: tem, tem1, tem2, temc, temv - real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 - real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv - real(kind=kind_phys) :: scork, rscor, hd, fro, sira - real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk - - real(kind=kind_phys) :: grav2, rcpdt, windik, wdir - real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge - - real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 - real(kind=kind_phys) :: belps, aelps, nhills, selps - - real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad - real(kind=kind_phys) :: pi2, rdi, gor, grcp, gocp, gr2, bnv2min - -! -! various integers -! - integer :: kmm1, kmm2, lcap, lcapp1 - integer :: npt, kbps, kbpsp1,kbpsm1 - integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll - integer :: k_mtb, k_zlow, ktrial, klevm1 - integer :: i, j, k -! -! initialize gamma and sigma - gamma(:) = gammad(:) - sigma(:) = sigmad(:) -! - rcpdt = 1.0 / (cpd*dtp) - grav2 = grav + grav -! - rgrav = 1.0/grav - rcpd = 1.0/cpd - rcpd2 = 0.5/cpd - rad_to_deg=180.0/pi - deg_to_rad=pi/180.0 - pi2 = 2.*pi - rdi = 1.0/rd - gor = grav/rd - grcp = grav*rcpd - gocp = grcp - gr2 = grav*gor - bnv2min = (pi2/1800.)*(pi2/1800.) -! -! mtb-blocking sigma_min and dxres => cires_initialize -! - sgrmax = maxval(sparea) ; sgrmin = minval(sparea) - dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) - - dxres = pi2*arad/float(imx) - hdxres = 0.5*dxres -! shilmin = sgrmin/nhilmax ! not used - moorthi - -! gammin = min(sso_min/dsmax, 1.) ! moorthi - with this results are not reproducible - gammin = min(sso_min/dxres, 1.) ! moorthi - -! sigmin = 2.*hpmin/dsmax !dxres ! moorthi - this will not reproduce - sigmin = 2.*hpmin/dxres !dxres - -! if (kdt == 1) then -! print *, sgrmax, sgrmin , ' min-max sparea ' -! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax -! print *, 'dxres/dsmax ', dxres, dsmax -! print *, ' shilmin gammin ', shilmin, gammin -! endif - - kxridge = float(imx)/arad * cdmbgwd(2) - - if (me == master .and. kdt == 1) then - print *, ' gwdps_v0 kxridge ', kxridge - print *, ' gwdps_v0 scale2 ', cdmbgwd(2) - print *, ' gwdps_v0 imx ', imx - print *, ' gwdps_v0 gam_min ', gammin - print *, ' gwdps_v0 sso_min ', sso_min - endif - - do i=1,im - idxzb(i) = 0 - zmtb(i) = 0.0 - zogw(i) = 0.0 - rdxzb(i) = 0.0 - tau_ogw(i) = 0.0 - tau_mtb(i) = 0.0 - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - tau_tofd(i) = 0.0 -! - ipt(i) = 0 -! - enddo - - do k=1,km - do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 - dudt_mtb(i,k) = 0.0 - dudt_ogw(i,k) = 0.0 - dudt_tms(i,k) = 0.0 - enddo - enddo - -! ---- for lm and gwd calculation points -!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 -!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) -!---- for lm and gwd calculation points - - - npt = 0 - - do i = 1,im - if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then - npt = npt + 1 - ipt(npt) = i - endif - enddo - - if (npt == 0) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin - return ! no gwd/mb calculation done - endif -!======================================================== - -! - if (do_adjoro ) then - - do i = 1,im -! arhills(i) = 1.0 -! - sigres = max(sigmin, sigma(i)) -! if (sigma(i) < sigmin) sigma(i)= sigmin - dxres = sqrt(sparea(i)) - if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres - aelps = min(2.*hprime(i)/sigres, 0.5*dxres) - if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) -! -! small-scale "turbulent" oro-scales < sso_min -! - if( aelps < sso_min ) then - -! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm -! - aelps = sso_min - if (belps < sso_min ) then - gamma(i) = 1.0 - belps = aelps*gamma(i) - else - gamma(i) = min(aelps/belps, 1.0) - endif - - sigma(i) = 2.*hprime(i)/aelps - gamma(i) = min(aelps/belps, 1.0) - - endif - - selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill - nhills = min(nhilmax, sparea(i)/selps) -! arhills(i) = max(nhills, 1.0) - -!333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) -! if (kdt==1 ) -! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, -! & belps*1.e-3, sigma(i),gamma(i) - - - enddo - endif !(do_adjoro ) - - - - do i=1,npt - iwklm(i) = 2 - idxzb(i) = 0 - kreflm(i) = 0 - enddo - - do k=1,km - do i=1,im - db(i,k) = 0.0 - ang(i,k) = 0.0 - uds(i,k) = 0.0 - enddo - enddo - - kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 - lcap = km ; lcapp1 = lcap + 1 - - cdmb4 = 0.25*cdmb - - do i = 1, npt - j = ipt(i) - elvmax(j) = min (elvmaxd(j)*0. + sigfac * hprime(j), hncrit) - izlow(i) = 1 ! surface-level - enddo -! - do k = 1, kmm1 - do i = 1, npt - j = ipt(i) - ztoph = sigfac * hprime(j) - zlowh = sigfacs* hprime(j) - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) -! if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) -! & iwklm(i) = max(iwklm(i), k+1 ) - if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) iwklm(i) = max(iwklm(i), k+1 ) - if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) - - enddo - enddo -! - do k = 1,km - do i =1,npt - j = ipt(i) - vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) - vtk(i,k) = vtj(i,k) / prslk(j,k) - ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels - taup(i,k) = 0.0 - enddo - enddo -! -! check ri_n or ri_mf computation -! - do k = 1,kmm1 - do i =1,npt - j = ipt(i) - rdz = 1. / (zmet(j,k+1) - zmet(j,k)) - tem1 = u1(j,k) - u1(j,k+1) - tem2 = v1(j,k) - v1(j,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz -! ti = 2.0 / (t1(j,k)+t1(j,k+1)) -! bvf2 = grav*(gocp+rdz*(vtj(i,k+1)-vtj(i,k)))* ti -! ri_n(i,k) = max(bvf2/shr2,rimin) ! richardson number -! - bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) - - bnv2(i,k+1) = max( bvf2, bnv2min ) - ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 -! -! add here computation for ktur and ogw-dissipation fro ve-gfs -! - enddo - enddo - k = 1 - do i = 1, npt - bnv2(i,k) = bnv2(i,k+1) - enddo -! -! level iwklm => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) -! - do i = 1, npt - j = ipt(i) - k_zlow = izlow(i) - if (k_zlow == iwklm(i)) k_zlow = 1 - delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,iwklm(i))) -! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,iwklm(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - pe (i) = 0.0 - ek (i) = 0.0 - bnv2bar(i) = 0.0 - enddo -! - do i = 1, npt - k_zlow = izlow(i) - if (k_zlow == iwklm(i)) k_zlow = 1 - do k = k_zlow, iwklm(i)-1 ! kreflm(i)= iwklm(i)-1 - j = ipt(i) ! laye-aver rho, u, v - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) ! trial mean u below - vbar(i) = vbar(i) + rdelks * v1(j,k) ! trial mean v below - roll(i) = roll(i) + rdelks * ro(i,k) ! trial mean ro below -! - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - enddo - enddo -! - do i = 1, npt - j = ipt(i) -! -! integrate from ztoph = sigfac*hprime down to zblk if exists -! find ph_blk, dz_blk like in LM-97 and ifs -! - ph_blk =0. - do k = iwklm(i), 1, -1 - phiang = atan2(v1(j,k),u1(j,k))*rad_to_deg - ang(i,k) = ( theta(j) - phiang ) - if ( ang(i,k) > 90. ) ang(i,k) = ang(i,k) - 180. - if ( ang(i,k) < -90. ) ang(i,k) = ang(i,k) + 180. - ang(i,k) = ang(i,k) * deg_to_rad - uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) -! - if (idxzb(i) == 0 ) then - dz_blk = zmeti(j,k+1) - zmeti(j,k) - pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk - - up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) - ek(i) = 0.5 * up(i) * up(i) - - ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) - -! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs -! if ( pe(i) >= ek(i) ) then - if ( ph_blk >= fcrit_gfs ) then - idxzb(i) = k - zmtb (j) = zmet(j, k) - rdxzb(j) = real(k, kind=kind_phys) - endif - - endif - enddo -! -! alternative expression: zmtb = max(heff*(1. -fcrit_gfs/fr), 0) -! fcrit_gfs/fr -! - goto 788 - - bnv = sqrt( bnv2bar(i) ) - heff = 2.*min(hprime(j),hpmax) - zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) - ulow(i) = sqrt(max(zw2,dw2min)) - fr = heff*bnv/ulow(i) - zw1 = max(heff*(1. -fcrit_gfs/fr), 0.0) - zw2 = zmet(j,2) - if (fr > fcrit_gfs .and. zw1 > zw2 ) then - do k=2, kmm1 - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) - if (zw1 <= zmetp .and. zw1 >= zmetk) exit - enddo - idxzb(i) = k - zmtb (j) = zmet(j, k) - else - zmtb (j) = 0. - idxzb(i) = 0 - endif - -788 continue -! -! --- the drag for mtn blocked flow -! - if ( idxzb(i) > 0 ) then - -! (4.16)-ifs - gam2 = gamma(j)*gamma(j) - bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 - cgam = 0.48*gamma(j) + 0.30*gam2 - - do k = idxzb(i)-1, 1, -1 - zlen = sqrt( (zmtb(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) - tem = cos(ang(i,k)) - cosang2 = tem * tem - sinang2 = 1.0 - cosang2 -! -! cos =1 sin =0 => 1/r= gam zr = 2.-gam -! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam -! - rdem = cosang2 + gam2 * sinang2 - rnom = cosang2*gam2 + sinang2 -! -! metoffice dec 2010 -! correction of h. wells & a. zadra for the -! aspect ratio of the hill seen by mean flow -! (1/r , r-inverse below: 2-r) - - rdem = max(rdem, 1.e-6) - r = sqrt(rnom/rdem) - zr = max( 2. - r, 0. ) - - sigres = max(sigmin, sigma(j)) - if (hprime(j)/sigres > dxres) sigres = hprime(j)/dxres - mtbridge = zr * sigres*zlen / hprime(j) -! (4.15)-ifs -! dbtmp = cdmb4 * mtbridge * & -! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) -! (4.16)-ifs - dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) - db(i,k)= dbtmp * uds(i,k) - enddo -! - endif - enddo -!............................. -!............................. -! end mtn blocking section -!............................. -!............................. -! -!--- orographic gravity wave drag section -! -! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 -! inside "cires_ugwp_initialize.f90" now -! - kmpbl = km / 2 - iwk(1:npt) = 2 -! -! meto/UK-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! - do k=3,kmpbl - do i=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem < dpmin) iwk(i) = k ! dpmin=50 mb - -!=============================================================== -! lev=111 t=311.749 hkm=0.430522 ps-p(iwk)=52.8958 -! below "hprime" - source of ogws and below zblk !!! -! 27 2 kpbl ~ 1-2 km < hprime -!=============================================================== - enddo - enddo -! -! iwk - adhoc gfs-parameter to select ogw-launch level between -! level ~0.4-0.5 km from surface or/and pbl-top -! in ugwp-v1: options to modify as htop ~ (2-3)*hprime > zmtb -! in ugwp-v0 we ensured that : zogw > zmtb -! - - kbps = 1 - kmps = km - k_mtb = 1 - do i=1,npt - j = ipt(i) - k_mtb = max(1, idxzb(i)) - - kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else ???? - kref(i) = max(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime - - if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above zmtb - kbps = max(kbps, kref(i)) - kmps = min(kmps, kref(i)) -! - delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - bnv2bar(i)= 0.0 - enddo -! - kbpsp1 = kbps + 1 - kbpsm1 = kbps - 1 - k_mtb = 1 -! - do i = 1,npt - k_mtb = max(1, idxzb(i)) - do k = k_mtb,kbps !kbps = max(kref) ;kmps= min(kref) - if (k < kref(i)) then - j = ipt(i) - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref - vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref - roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - endif - enddo - enddo -! -! orographic asymmetry parameter (oa), and (clx) - do i = 1,npt - j = ipt(i) - wdir = atan2(ubar(i),vbar(i)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) - clx(i) = clx4(j,mod(nwd-1,4)+1) - enddo -! - do i = 1,npt - dtfac(i) = 1.0 - icrilv(i) = .false. ! initialize critical level control vector - ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) - xn(i) = ubar(i) / ulow(i) - yn(i) = vbar(i) / ulow(i) - enddo -! - do k = 1, kmm1 - do i = 1,npt - j = ipt(i) - velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) - - enddo - enddo -! -!------------------ -! v0: incorporates latest modifications for kxridge and heff/hsat -! and taulin for fr <=fcrit_gfs -! and concept of "clipped" hill if zmtb > 0. to make -! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data -! it is still used the "single-orowave"-approach along ulow-upwind -! -! in contrast to the 2-orthogonal wave (2otw) schemes of ifs/meto/e-canada -! 2otw scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b -! with 2-stresses: taub_a & taub_b as of Phillips (1984) -!------------------ - taub(:) = 0. ; taulin(:)= 0. - do i = 1,npt - j = ipt(i) - bnv = sqrt( bnv2bar(i) ) - heff = min(hprime(j),hpmax) - - if( zmtb(j) > 0.) heff = max(sigfac*heff-zmtb(j), 0.)/sigfac - if (heff <= 0) cycle - - hsat = fcrit_gfs*ulow(i)/bnv - heff = min(heff, hsat) - - fr = min(bnv * heff /ulow(i), frmax) -! - efact = (oa(i) + 2.) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) -! - coefm = (1. + clx(i)) ** (oa(i)+1.) -! - xlinv(i) = coefm * cleff ! effective kxw for lin-wave - xlingfs = coefm * cleff -! - tem = fr * fr * oc(j) - gfobnv = gmax * tem / ((tem + cg)*bnv) -! -!new specification of xlinv(i) & taulin(i) - - sigres = max(sigmin, sigma(j)) - if (heff/sigres > hdxres) sigres = heff/hdxres - inv_b2eff = 0.5*sigres/heff - kxridge = 1.0 / sqrt(sparea(j)) - xlinv(i) = xlingfs !or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge - taulin(i) = 0.5*roll(i)*xlinv(i)*bnv*ulow(i)*heff*heff*pgwd4 - - if ( fr > fcrit_gfs ) then - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact ! nonlinear flux tau0...xlinv(i) -! - else -! taub(i) = taulin(i) ! linear flux for fr <= fcrit_gfs - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact -! - endif -! -! - k = max(1, kref(i)-1) - tem = max(velco(i,k)*velco(i,k), dw2min) - scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level -! -! diagnostics for zogw > zmtb -! - zogw(j) = zmeti(j, kref(i) ) - enddo -! -!----set up bottom values of stress -! - do k = 1, kbps - do i = 1,npt - if (k <= kref(i)) taup(i,k) = taub(i) - enddo - enddo - - if (strsolver == 'pss-1986') then - -!====================================================== -! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" -! in v1-orogw linsatdis of "wam-2017" -! with llwb-mechanism for -! rotational/non-hydrostat ogws important for -! highres-fv3gfs with dx < 10 km -!====================================================== - - do k = kmps, kmm1 ! vertical level loop from min(kref) - kp1 = k + 1 - do i = 1, npt -! - if (k >= kref(i)) then - icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) - endif - enddo -! - do i = 1,npt - if (k >= kref(i)) then - if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then - temv = 1.0 / max(velco(i,k), velmin) -! - if (oa(i) > 0. .and. kp1 < kref(i)) then -! - scork = bnv2(i,k) * temv * temv - rscor = min(1.0, scork / scor(i)) - scor(i) = scork - else - rscor = 1. - endif -! - brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface -! tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*velco(i,k)*0.5 - - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*0.5 & - * max(velco(i,k), velmin) - hd = sqrt(taup(i,k) / tem1) - fro = brvf * hd * temv -! -! rim is the "wave"-richardson number by palmer,shutts, swinbank 1986 -! - - tem2 = sqrt(ri_n(i,k)) - tem = 1. + tem2 * fro - ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) -! -! check stability to employ the 'dynamical saturation hypothesis' -! of palmer,shutts, swinbank 1986 -! - if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf - taup(i,kp1) = tem1 * hd * hd - else - taup(i,kp1) = taup(i,k) * rscor - endif -! - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - endif - endif - enddo - enddo -! -! zero momentum deposition at the top model layer -! - taup(1:npt,km+1) = taup(1:npt,km) -! -! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud -! - do k = 1,km - do i = 1,npt - taud(i,k) = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) - enddo - enddo - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!------if the gravity wave drag would force a critical line in the -!------layers below sigma=rlolev during the next deltim timestep, -!------then only apply drag until that critical line is reached. -! empirical implementation of the llwb-mechanism: lower level wave breaking -! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb -! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws -!2019: this option limits sensitivity of taux/tauy to increase/decrease of taub -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - do k = 1,kmm1 - do i = 1,npt - if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then - - if(taud(i,k) /= 0.) then - tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 - dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) -! dtfac(i) = 1.0 - endif - endif - enddo - enddo -! -!--------------------------- orogw-solver of gfs pss-1986 -! - else -! -!-----------Unified orogw-solver of wam2017 -! -! sigres = max(sigmin, sigma(j)) -! if (heff/sigres.gt.dxres) sigres=heff/dxres -! inv_b2eff = 0.5*sigres/heff -! xlinv(i) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./lridge - - dtfac(:) = 1.0 - - call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & - dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & - grav, con_omega, rd, & - del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) - - endif ! oro_wam_2017 - linsatdis-solver of wam-2017 -! -!---- above orogw-solver of wam2017 -! -! tofd as in beljaars-2004 -! -! --------------------------- - if( do_tofd ) then - axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0) then - print *, 'vay do_tofd from surface to ', ztop_tofd - endif - do i = 1,npt - j = ipt(i) - zpbl = zmet( j, kpbl(j) ) - - sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso - - zsurf = zmeti(j,1) - do k=1,km - zpm(k) = zmet(j,k) - up1(k) = u1(j,k) - vp1(k) = v1(j,k) - enddo - - call ugwp_tofd1d(km, cpd, sigflt, elvmaxd(j), zsurf, zpbl, & - up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1,km - axtms(j,k) = utofd1(k) - aytms(j,k) = vtofd1(k) -! -! add tofd to gw-tendencies -! - pdvdt(j,k) = pdvdt(j,k) + aytms(j,k) - pdudt(j,k) = pdudt(j,k) + axtms(j,k) - enddo -!2018-diag - tau_tofd(j) = sum( utofd1(1:km)* del(j,1:km)) - enddo - endif ! do_tofd - -!-------------------------------------------- -! combine oro-drag effects MB +TOFD + OGWs -!-------------------------------------------- -! + diag-3d - - dudt_tms = axtms - tau_ogw = 0. - tau_mtb = 0. - - do k = 1,km - do i = 1,npt - j = ipt(i) -! - eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) -! - if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then -! -! if blocking layers -- no ogws -! - dbim = db(i,k) / (1.+db(i,k)*dtp) - pdvdt(j,k) = - dbim * v1(j,k) +pdvdt(j,k) - pdudt(j,k) = - dbim * u1(j,k) +pdudt(j,k) - eng1 = eng0*(1.0-dbim*dtp)*(1.-dbim*dtp) - - dusfc(j) = dusfc(j) - dbim * u1(j,k) * del(j,k) - dvsfc(j) = dvsfc(j) - dbim * v1(j,k) * del(j,k) -!2018-diag - dudt_mtb(j,k) = -dbim * u1(j,k) - tau_mtb(j) = tau_mtb(j) + dudt_mtb(j,k)* del(j,k) - - else -! -! ogw-s above blocking height -! - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) * pgwd - dtauy = taud(i,k) * yn(i) * pgwd - - pdvdt(j,k) = dtauy +pdvdt(j,k) - pdudt(j,k) = dtaux +pdudt(j,k) - - unew = u1(j,k) + dtaux*dtp ! pdudt(j,k)*dtp - vnew = v1(j,k) + dtauy*dtp ! pdvdt(j,k)*dtp - eng1 = 0.5*(unew*unew + vnew*vnew) -! - dusfc(j) = dusfc(j) + dtaux * del(j,k) - dvsfc(j) = dvsfc(j) + dtauy * del(j,k) -!2018-diag - dudt_ogw(j,k) = dtaux - tau_ogw(j) = tau_ogw(j) +dtaux*del(j,k) - endif -! -! local energy deposition sso-heat -! - pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt - enddo - enddo -! dusfc w/o tofd sign as in the era-i, merra and cfsr - do i = 1,npt - j = ipt(i) - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) - tau_mtb(j) = -rgrav * tau_mtb(j) - tau_ogw(j) = -rgrav * tau_ogw(j) - tau_tofd(j) = -rgrav * tau_tofd(j) - enddo - - return - - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0) then - print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' -! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' - print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' - print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' -! print *, maxval(tau_tofd), ' tau_tofd ' -! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' -! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' - if (maxval(abs(pdudt))*86400. > 100.) then - - print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' - print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' - print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' - print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' - print *, maxval(del), minval(del), ' del gwdps-v0 ' - print *, maxval(zmet),minval(zmet), 'zmet' - print *, maxval(zmeti),minval(zmeti), 'zmeti' - print *, maxval(prsi), minval(prsi), ' prsi ' - print *, maxval(prsl), minval(prsl), ' prsl ' - print *, maxval(ro), minval(ro), ' ro-dens ' - print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' - print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' - print * - do i =1, npt - j= ipt(i) - print *,zogw(j)/hprime(j), zmtb(j)/hprime(j), & - zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) -! -!.................................................................... -! -! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m -! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km -! we must exclude blocking by small ridges -! vay-kref < iblk zogw-lev 15 block-level: 39 -! -! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters -! max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), minwnd) -! max(dw2,dw2min) * rdz * rdz -! ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) -! tem = max(velco(i,k)*velco(i,k), 0.1) -! temv = 1.0 / max(velco(i,k), 0.01) -! & * max(velco(i,k),0.01) -!.................................................................... - enddo - print * - stop - endif - endif - -!cires_ugwp_solv2_v1.f90 - return - end subroutine gwdps_oro_v1 - - -end module cires_ugwp_orolm97_v1 diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 80b8ce1ca..c8618e1c8 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 deleted file mode 100644 index 46a5fb833..000000000 --- a/physics/cires_ugwp_solv2_v1_mod.F90 +++ /dev/null @@ -1,829 +0,0 @@ -module cires_ugwp_solv2_v1_mod - - -contains - - -!--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 -! dissipative solver with NonHyd/ROT-effects -! reflected GWs treated as waves with "negligible" flux, -! they are out of given column -!--------------------------------------------------- - subroutine cires_ugwp_solv2_v1(im, levs, dtp , & - tm , um, vm, qm, prsl, prsi, zmet, zmeti, & - prslk, xlatd, sinlat, coslat, & - grav, cpd, rd, rv, omega, pi, fv, & - pdudt, pdvdt, pdtdt, dked, tauabs, wrms, trms, & - tau_ngw, mpi_id, master, kdt) -! -!-------------------------------------------------------------------------------- -! nov 2015 alternative gw-solver for nggps-wam -! nov 2017 nh/rotational gw-modes for nh-fv3gfs -! oct 2019 adding empirical satellite-based -! source function and *F90 CIRES-style of the code -! -------------------------------------------------------------------------------- -! - - use machine, only : kind_phys - - use cires_ugwp_module_v1,only : krad, kvg, kion, ktg - - use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - - use ugwp_common_v1 , only : dw2min, velmin, hpscale, rhp, rh4 -! - use ugwp_wmsdis_init_v1, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & - maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & - nslope, ilaunch, zms, & - zci, zdci, zci4, zci3, zci2, & - zaz_fct, zcosang, zsinang, nwav, nazd, & - zcimin, zcimax, rimin, sc2, sc2u, ric -! - implicit none -!23456 - - integer, intent(in) :: levs ! vertical level - integer, intent(in) :: im ! horiz tiles - - real ,intent(in) :: dtp ! model time step - real ,intent(in) :: vm(im,levs) ! meridional wind - real ,intent(in) :: um(im,levs) ! zonal wind - real ,intent(in) :: qm(im,levs) ! spec. humidity - real ,intent(in) :: tm(im,levs) ! kinetic temperature - - real ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real ,intent(in) :: prslk(im,levs) ! mid-layer exner function - real ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav - real ,intent(in) :: prsi(im,levs+1) ! interface pressure - real ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters - real ,intent(in) :: xlatd(im) ! lat was in radians, now with xlat_d in degrees - real ,intent(in) :: sinlat(im) - real ,intent(in) :: coslat(im) - real ,intent(in) :: tau_ngw(im) - - integer, intent(in):: mpi_id, master, kdt - - real ,intent(in) :: grav, cpd, rd, rv, omega, pi, fv -! -! -! out-gw effects -! - real ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency - real ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency - real ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp - real ,intent(out) :: dked(im,levs) ! gw-eddy diffusion -! -! GW diagnostics => next move it to "module_gw_diag" -! - real ,intent(out) :: tauabs(im,levs) ! - real ,intent(out) :: wrms(im,levs) ! - real ,intent(out) :: trms(im,levs) ! - - real :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) -! -! local =========================================================================================== - real :: taux(levs+1) ! EW component of vertical momentum flux (pa) - real :: tauy(levs+1) ! NS component of vertical momentum flux (pa) - real :: fpu(nazd, levs+1) ! az-momentum flux - real :: ui(nazd, levs+1) ! azimuthal wind - - real :: fden_bn(levs+1) ! density/brent - real :: flux_z(nwav,levs+1) - real :: flux(nwav, nazd) -! -! =============================================================================================== -! ilaunch:levs ....... MOORTHI's improvements -! all computations of GW-effects include interface layers from ilaunch+1 to levs +1 -! at k=levs+1, extrapolation of MF-state has been made, "ideally" all spectral modes should -! be absorbed; 2-options for this "ideal" requirement -! a) properly truncate GW-spectra ; b) dissipate all GW-energy in the top layers ( GW-sponge) -!===================================================================================================== -! - real :: bn(levs+1) ! interface BV-frequency - real :: bn2(levs+1) ! interface BV*BV-frequency - real :: rhoint(levs+1) ! interface density - real :: uint(levs+1) ! interface zonal wind - real :: vint(levs+1) ! meridional wind - - real :: irhodz_mid(levs), dzdt(levs+1), bnk(levs+1), rhobnk(levs+1) - - real :: v_zmet(levs+1) - real :: vueff(levs+1) - real :: dfdz_v(nazd, levs) ! axj = -df*rho/dz directional momentum deposition - - - real :: suprf(levs+1) ! RF-super linear dissipation - - real, dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet - real, dimension(levs+1) :: aprsi, azmeti - - real :: wrk3(levs) - real, dimension(levs) :: uold, vold, told, unew, vnew, tnew - real, dimension(levs) :: dktur, rho, rhomid, adif, cdif - - real :: rdci(nwav), rci(nwav) - real :: wave_act(nwav, nazd) ! active waves at given vert-level - real :: ul(nazd) ! velocity in azimuthal direction at launch level - real :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real :: c2f2, cf1 - - - real :: flux_norm ! norm-factor - real :: taub_src, rho_src -! -! scalars -! - real :: zthm, dtau, cgz, ucrit_maxdc - real :: vm_zflx_mode, vc_zflx_mode - real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 - real :: ucrit_max - real :: pwrms, ptrms - real :: zu, zcin, zcin2, zcin3, zcin4, zcinc - real :: zatmp, fluxs, zdep, ze1, ze2 -! - real :: rcpdl, grav2cpd, rcpd, rcpd2, pi2, rad_to_deg - real :: deg_to_rad, rdi, gor, grcp, gocp, bnv2min, bnv2max, gr2 - real :: grav2, rgrav, rgrav2, mkzmin, mkz2min -! - real :: zdelp, zdelm, taud_min - real :: tvc, tvm, ptc, ptm - real :: umfp, umfm, umfc, ucrit3 - real :: fmode, expdis, fdis - real :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit - real :: v_wdi, v_wdpc - real :: ugw, vgw, ek1, ek2, rdtp, rdtp2 - - integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop -! -! Kturb-part -! - - real :: uz, vz, shr2 , ritur, ktur - - real :: kamp, zmetk, zgrow - real :: stab, stab_dt, dtstab - integer :: nstab, ist, anstab(levs) - real :: w1, w2, w3, dtdif - - real :: dzmetm, dzmetp, dzmetf, bdif, kturp - real :: bnrh_src -!-------------------------------------------------------------------------- -! - - if (mpi_id == master .and. kdt < 2) then - print *, im, levs, dtp, kdt, ' vay-solv2-v1' - print *, minval(tm), maxval(tm), ' min-max-tm ' - print *, minval(vm), maxval(vm), ' min-max-vm ' - print *, minval(um), maxval(um), ' min-max-um ' - print *, minval(qm), maxval(qm), ' min-max-qm ' - print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' - print *, minval(prsi), maxval(prsi), ' min-max-Pint ' - print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' - print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' - print *, minval(prslk), maxval(prslk), ' min-max-Exner ' - print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' - print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! - endif - - if (idebug_gwrms == 1) then - tauabs=0.0; wrms =0.0 ; trms =0.0 - endif - - - grav2 = grav + grav - rgrav = 1.0/grav - rgrav2 = rgrav*rgrav - rdi = 1.0/rd - gor = grav/rd - gr2 = grav*gor - rcpd = 1.0/cpd - rcpd2 = 0.5/cpd - rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - pi2 = 2.0*pi - grcp = grav*rcpd - gocp = grcp - grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - rad_to_deg=180.0/pi - deg_to_rad=pi/180.0 - bnv2min = (pi2/1800.)*(pi2/1800.) - bnv2max = (pi2/30.)*(pi2/30.) - mkzmin = pi2/80.0e3 - mkz2min = mkzmin*mkzmin - - rci(:) = 1./zci(:) - rdci(:) = 1./zdci(:) - - rdtp = 1./dtp - rdtp2 = 0.5*rdtp -! -! launch level control ksrc > 2 -! - - ksrc= max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop= levs+1 - - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo - -!----------------------------------------------------------- -! column-based j=1,im pjysics with 1D-arrays -!----------------------------------------------------------- - DO j=1, im - - jl =j - tx1 = 2*omega * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max -! -! ngw-fluxes at all gridpoints (with tau_min at least) -! - taub_src = max(tau_ngw(jl), tau_min) - aum(km2:levs) = um(jl,km2:levs) - avm(km2:levs) = vm(jl,km2:levs) - atm(km2:levs) = tm(jl,km2:levs) - aqm(km2:levs) = qm(jl,km2:levs) - aprsl(km2:levs) = prsl(jl,km2:levs) - azmet(km2:levs) = zmet(jl,km2:levs) - aprsi(km2:levs+1) = prsi(jl,km2:levs+1) - azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) - - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - -! --------------------------------------------- -! interface mean flow parameters launch -> levs+1 -! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk) * (1. +fv*aqm(jk)) - tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) - ptc = tvc/ prslk(jl, jk) - ptm = tvm/prslk(jl,jk-1) -! - zthm = 2.0 / (tvc+tvm) -! - uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) - vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = azmeti(jk+1)-azmeti(jk) ! >0 ...... dz-meters - zdelm = 1./(azmet(jk)-azmet(jk-1)) ! 1/dz ...... 1/meters - dzdt(jk) = dtp/zdelp -! -! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) -! - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) - bnk(jk) = bn(jk)*v_kxw - rhobnk(jk)=rhoint(jk)/bnk(jk)*v_kxw - wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src - - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] -! -! -! diagnostics -Kzz above PBL -! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - kamp = sqrt(shr2)*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min)+kvg(k), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur*0. + 2.e-5*exp( zmetk) - enddo - - if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) - enddo - endif - -! -! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! - jk = levs - - suprf(ktop) = kion(jk) - - rhoint(ktop) = aprsi(ktop)*rdi/atm(jk) - - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) - - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) - bnk(ktop) = bn(ktop)*v_kxw - - rhobnk(ktop) = rhoint(ktop)/bnk(ktop)*v_kxw - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi - bnrh_src = bvi/rhoint(ksrc) -! -! define intrinsic velocity (relative to ilaunch) u(z)-u(zo), and coefficinets -! ------------------------------------------------------------------------------------------ - do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) - enddo -! - do jk=ksrc, ktop - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. - enddo - enddo -! ----------------------------------------- -! set launch momentum flux spectral density -! ----------------------------------------- - - fpu(1, ksrc) =0. - do inc=1,nwav - zcin = zci(inc) - zcin4 = zci4(inc)/bvi4 -! - if(nslope == 0) then - zcin3 = zci3(inc)/bvi3 - flux(inc,1) = zcin/(1.+zcin3) - endif - - if(nslope == 1) flux(inc,1) = zcin/(1.+zcin4) - if(nslope == 2) flux(inc,1)= zcin/(1.+zcin4*zcin*rcms) - -! integrate (flux x dx) - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) - - do iaz=1,nazd - akzw(inc, iaz,ksrc:ktop) = bvi*rci(inc) - enddo - - enddo -! - flux_norm = taub_src / fpu(1, ksrc) -! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - enddo - -! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - bnrh_src=bnrh_src*flux_norm - do jk=ksrc, ktop - fden_bn(jk) = bnrh_src*rhoint(jk) / bn(jk) !*bvi/rhoint(ksrc) - enddo - -! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo - - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif - -! copy flux-1 into other azimuths -! -------------------------------- - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) - enddo - enddo - -! constant flux below ilaunch - do jk=km1, ksrc - do inc=1, nwav - flux_z(inc,jk)=flux(inc,1) - enddo - enddo - - wave_act(:,:) = 1.0 -! vertical do-loop - do jk=ksrc, levs - jkp = jk+1 -! azimuth do-loop - do iaz=1, nazd - - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) -! wave-cin loop - do inc=1, nwav - - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if(wave_act(inc,iaz) == 1.0) then -!======================================================================= -! discrete mode -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -!======================================================================= - - v_cdp = zcin - umfp - - if (v_cdp .le. ucrit_max) then -! -! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max ; wave's absorption -! - wave_act(inc,iaz) =0. - akzw(inc, iaz, jkp) = pi/v_zmet(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - flux_z(inc,jkp) = fluxs -! ucrit_maxdc =0. - else - - v_wdp = v_kxw*v_cdp - wdop2 = v_wdp* v_wdp - v_cdp2=v_cdp*v_cdp -! -! rotational cut-off -! - cdf2 = v_cdp2 - c2f2 - - if (cdf2 > 0.0) then - kzw2 = (bn2(jkp)-wdop2)/Cdf2 - else - kzw2 = mkz2min - endif - - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw -! -!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) -! Kds = kxw*Cdf1*rhp2/kzw3 -! - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + supRF(jk) ! supRF - diss due to FRF-FV3dycore for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc -! - ze1 = v_kzi*v_zmet(jk) - - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1./(1.+ ze1) - endif - -! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) - - else ! kzw2 <= mkz2min large "Lz"-reflection - - expdis = 1.0 - v_kzw = mkzmin - - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - endif - - fdis = fmode*expdis -! -! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 -! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] -! -! fluxs= fden_bn(jkp)*cdf2*zcinc - fluxs= fden_bn(jkp)*sqrt(cdf2) - -! -! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin -! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) -! - zdep = wave_act(inc,iaz)* (fdis-fluxs) - if(zdep > 0.0 ) then -! subs on sat-limit - flux(inc,iaz) = fluxs - flux_z(inc,jkp) = fluxs - else -! assign dis-ve flux - flux(inc,iaz) = fdis - flux_z(inc,jkp) = fdis - endif - -! cgz = bnk(jk)/max(mkz2min, kzw2) - - dtau = flux_z(inc,jk)-flux_z(inc,jkp) - if (dtau .lt. 0) flux_z(inc,jkp) = flux_z(inc,jk) - -! if (dtau .ge. ucrit_maxdc) then -! flux_z(inc,jkp) = max(flux_z(inc,jk)-ucrit_maxdc, 0.) -! ze1 = zci(inc)-umfc-ucrit_maxdc -! write(6,287) dzdt(jk)/cgz, dtau/ucrit_maxdc, flux_z(inc,jkp)*1.e3, fluxs*1.e3, jk, zci(inc), ze1 -! -! endif -! 287 format(' dtau >ucrit_max', 4(2x, F12.7), I4, 2x, 2(2x,F8.3)) -! - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 - - -! - enddo ! wave-inc-loop -! -! integrate over spectral modes fpu(y, z, azimuth) wave_act(jl,inc,iaz)*flux(jl,inc,iaz)*[d("zcinc")] -! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. -! new arrays - - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif - - - dfdz_v(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - - zcinc =zdci(inc) - vc_zflx_mode = flux(inc,iaz) - fpu(iaz, jkp) = fpu(iaz,jkp) + vc_zflx_mode*zcinc - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! (heat deposition integration over spectral mode for each azimuth -! later sum over selected azimuths as "non-negative" scalars) -! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc - zdelp = wrk3(jk)*abs(zci(inc)-umfc) *zcinc - vm_zflx_mode = flux_z(inc,jk) - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) +(vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - endif - enddo !waves inc=1,nwav - - ze1 =fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 -! -------------- - enddo ! end Azimuth do-loop - -! -! extra- eddy wave dissipation to limit GW-rms -! tx1 = sum(abs(dfdz_v(jk,1:nazd)))/bn2(jk) -! ze1=max(dked_min, tx1) -! ze2=min(dked_max, ze1) -! vueff(jkp) = ze2 + vueff(jkp) -! - - - enddo ! end Vertical do-loop -! -! top-layers constant interface-fluxes and zero-heat -! - fpu(1:nazd,ktop) = fpu(1:nazd, levs) - dfdz_v(1:nazd, levs) = 0.0 - -! --------------------------------------------------------------------- -! sum contribution for total zonal and meridional fluxes + -! energy dissipation -! --------------------------------------------------- -! -!======================================================================== -! at the source level and below taux = 0 (taux_E=-taux_W by assumption) -!======================================================================== - - - - do jk=ksrc, levs - taux(jk) = 0.0 - tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk)+ dfdz_v(iaz,jk) - enddo - enddo - jk = ktop; taux(jk)=0.; tauy(jk)=0. - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - enddo - - if (idebug_gwrms == 1) then - - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - - endif -! - - do jk=ksrc,levs - jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp - ze2 = (tauy(jkp)-tauy(jk))* zdelp - - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - pdudt(jl,jk) = -ze1 - pdvdt(jl,jk) = -ze2 -! -! Cx =0 based Cx=/= 0. above -! -! - if (knob_ugwp_doheat == 1) then -! -! ek1 =aum(jk)*aum(jk) +avm(jk)*avm(jk) -! ugw = aum(jk)- ze1*dtp; vgw = avm(jk)- ze2*dtp -! ek2 = ugw*ugw +vgw*vgw -! pdtdt(jl,jk) = rdtp2*max(ek1-ek2, 0.0) !=ze1*um + 0.5*ze1^2*dtp -! pdtdt(jl,jk) = max(ze1*aum(jk) + ze2*avm(jk), 0.) ! gw_eff => in "ze1 and ze2" - pdtdt(jl,jk) = max(pdtdt(jl,jk) , 0.)*gw_eff - endif - - if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt - ze1 = max(dked_min, pdtdt(jl,jk)/bn2(jk)) - dked(jl,jk) = min(dked_max, ze1) - - enddo -! -! add limiters/efficiency for "unbalanced ics" if it is needed -! - do jk=ksrc,levs - pdtdt(jl,jk) = pdtdt(jl,jk)*rcpd - enddo -! - dktur(1:levs) = dked(jl,1:levs) -! - do ist= 1, 3 - do jk=ksrc,levs-1 - adif(jk) = .25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - -! dked(jl, ksrc:levs-1) = dktur(ksrc:levs-1) -! dked(jl, levs) =dked(jl, levs-1) - -! -! perform "diffusive" 3-point smoothing of "u-v-t" -! from the surface to the "top" -! - if (knob_ugwp_dokdis == 2) then - - uold(1:levs) = aum(1:levs)+pdudt(jl,1:levs)*dtp - vold(1:levs) = avm(1:levs)+pdvdt(jl,1:levs)*dtp - told(1:levs) = atm(1:levs)+pdtdt(jl,1:levs)*dtp - - do jk=1,levs - zmetk= azmet(jk)*rhp - ktur = kvg(k) + 2.e-5*exp( zmetk) - dktur(jk) = dked(jl,jk) + ktur - enddo - - dzmetm= azmet(ksrc)- azmet(ksrc-1) - - do jk=2,levs-1 - dzmetf = (azmeti(jk+1)- azmeti(jk))*rhomid(jk) - ktur = .5*(dktur(jk-1)+dktur(jk)) *rhoint(jk)/dzmetf - kturp = .5*(dktur(jk+1)+dktur(jk))*rhoint(jk+1)/dzmetf - - dzmetp = azmet(jk+1)-azmet(jk) - Adif(jk) = ktur/dzmetm - Cdif(jk) = kturp/dzmetp - bdif = adif(jk)+cdif(jk) - if (rdtp < bdif ) then - Anstab(jk) = nint( bdif/rdtp + 1) - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - if (nstab .ge. 2) print *, 'nstab ', nstab - dtdif = dtp/real(nstab) - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = nstab*rdtp-Adif(k)-Cdif(k) - unew(k) = uold(k)*Bdif+ uold(k-1)*Adif(k) + uold(k)*Cdif(k) - vnew(k) = vold(k)*Bdif+ vold(k-1)*Adif(k) + vold(k)*Cdif(k) - tnew(k) = told(k)*Bdif+ told(k-1)*Adif(k) + told(k)*Cdif(k) - enddo - uold = unew*dtdif - vold = vnew*dtdif - told = tnew*dtdif - enddo -! -! create "smoothed" tendencies by molecular + GW-eddy diffusion -! - do k=ksrc,levs-1 - pdtdt(jl,jk)= rdtp*(told(k) - tm(jl,k)) - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 -! -! add eddy viscosity heating -! pdtdt(jl,jk) = pdtdt(jl,jk) - max(ze1*aum(jk) + ze2*avm(jk), 0.) *rcpd -! - enddo - - - ENDIF ! dissipative IF-loop for "abrupt" tendencies - - enddo ! J-loop -! - - - RETURN - -! -! Print/Debugging ----------------------------------------------------------------------- -! - 239 continue - if (kdt ==1 .and. mpi_id == master) then -! - print *, 'ugwp-vay: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwp-vay: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwp-vay: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwp-vay: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - - print * - - endif - - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' -! -! print *, ' ugwp -heating rates ' - endif - - - - return - end subroutine cires_ugwp_solv2_v1 - - -end module cires_ugwp_solv2_v1_mod diff --git a/physics/cires_ugwp_solvers.F90 b/physics/cires_ugwp_solvers.F90 deleted file mode 100644 index 6736daf6a..000000000 --- a/physics/cires_ugwp_solvers.F90 +++ /dev/null @@ -1,664 +0,0 @@ -! GW SOLVERS: -!=========== SOLVER_ORODIS; SOLVER_WMSDIS, SOLVER_LSATDIS -! + RF_DAMP if it is needed along with ugwp_tofd -!=========== -! Note in contrast to dycore vertical indices: surface=1 top=levs -! -! Collection of main friction-GWD solvers -! -! subroutine ugwp_oro -! -! subroutine gw_solver_linsatdis -! subroutine gw_solver_wmsdis -! subroutine rf_damp -! -! =========== -! -! - subroutine ugwp_oro(im, levs, dtp, kdt,me, lprnt, fcor, c2f2, & - u, v, tkin, pint, delp, pmid, pexner, gzint, gzmid, orostat, & - hpbl, axz, ayz, edis, kdis, dusfc, dvsfc, & - dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, dusfc_lwb, dvsfc_lwb, & - zmtb, zlwb, zogw, tauf_ogw, tauz_ogw, axmtb, axlwb, axtms ) -!---------------------------------------------------------------------- -! COORDE-output: 6-hour inst: U, V, T, PMSL, PS, HT (ounce) -! 3D 6-hr aver: DYN-U, SSO-U, PBL-U, AF-U1.... -! 2D 6-hr aver: tau_SSO, tau_GWD, tau_BL; & -! tau_sso = tau_mtb + tau_tofd + tau_lwb +tau_ogw -! ZM 6-hr aver: tau_RES = PS*dH/dx -zonal mean -! Experiments: Midlat 80-200km -! LR_CTL; ; LR_NOSSO with TOFD/TMS; -! LR_NOGWD (MTN+TOFD); LR_GWD4 --- 4 times taub -!---------------------------------------------------------------------- - use machine , only : kind_phys - use ugwp_oro_init, only : cdmb, cleff, sigfac, hncrit, hpmin, hminmt - use ugwp_oro_init, only : gamm_std, sigma_std - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - - - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - - implicit none - logical :: lprnt - integer :: im, levs - integer :: me - integer :: kdt - real(kind_phys) :: dtp - real(kind_phys), dimension(im) :: hpbl ! pbl-height in meters - real(kind_phys), dimension(im) :: fcor, c2f2 - real(kind_phys), dimension(im, 14) :: orostat - real(kind_phys), dimension(im, levs) :: u, v, tkin, q - - real(kind_phys), dimension(im, levs) :: pmid, pexner, gzmid, delp - real(kind_phys), dimension(im, levs+1) :: pint, gzint - - - real(kind_phys), dimension(im, levs) :: axz, ayz, edis, kdis ! total 6-hr averaged tendencies - real(kind_phys), dimension(im, levs) :: krf2d - real(kind_phys), dimension(im, levs) :: tauz_ogw, axmtb, axlwb, axtms ! 3-sub components axogw = axz-(axmtb+axlwb+axtms) - real(kind_phys), dimension(im) :: tauf_ogw ! total-source momentum flux - - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw - - real(kind_phys), dimension(im) :: dusfc, dvsfc ! total tausfc_sso - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb ! integrated tau_mtb - real(kind_phys), dimension(im) :: dusfc_ogw, dvsfc_ogw ! integrated tau_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb ! integrated tau_lwb - real(kind_phys), dimension(im) :: dusfc_tofd, dvsfc_tofd ! integrated tau_tofd - -! -! mu=hprime gamm=a/b sigma theta -! which stand for the standard deviation, the anisotropy, the slope and the orientation of the orography. -! - real(kind_phys) :: elvmax(im) - real(kind_phys) :: hprime(im) - - real(kind_phys) :: theta !the orienatation, angle - real(kind_phys) :: sigma !the slope dh/dx - real(kind_phys) :: gamm !the anisotropy see ifs-oro - - real(kind_phys) :: oc, oa4(4), clx4(4) !kim & doyle 2005 .... attempt to do TOFD ..? -! - integer, allocatable :: k_elev(:), k_mtb(:), k_ogw(:), k_lee(:), k_tofd(:) - - real(kind_phys) wk(im) - - real(kind_phys) eng0, eng1 -! -! -! - real(kind_phys), dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid1, pex - - real(kind_phys), dimension(levs+1) :: taudz, rhoi, rim_z, pint1, zpi - real(kind_phys), dimension(levs) :: drtau, kdis_oro -! - real (kind_phys) :: elvp, elvpd, dtaux, dtauy - real(kind_phys) :: loss, mtb_fric, mbx, mby - real(kind_phys) :: sigflt - - real(kind_phys) :: zpbl = 2000. ! can be passed from PBL physics as in gwdps.f -! - logical icrilv(im) -! -!---- mountain/oro gravity wave drag +TOFD -! - real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1, epstofd1, krf_tofd1 -! - real(kind=kind_phys), dimension(levs) :: drlee, drmtb, drlow, drogw - real(kind_phys) :: r_cpdt, acc_lim - real(kind_phys), dimension(im) :: tautot, tauogw, taumtb, taulee, taurf - real(kind_phys) :: xn, yn, umag, kxridge, & - tx1, tx2 - real(kind=kind_phys),dimension(levs+1):: tau_src - - integer :: npt, krefj, kdswj, kotr, i, j, k - integer :: ipt(im) - -! -! copy 1D -! - do i=1, im - hprime(i) = orostat(i, 1) - elvmax(i) = orostat(i, 14) -! - tautot(i) = 0.0 - tauogw(i) = 0.0 - taumtb(i) = 0.0 - taulee(i) = 0.0 - taurf(i) = 0.0 -! - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - dusfc_mb(i) = 0.0 - dvsfc_mb(i) = 0.0 - dusfc_ogw(i) = 0.0 - dvsfc_ogw(i) = 0.0 - dusfc_lwb(i) = 0.0 - dvsfc_lwb(i) = 0.0 - dusfc_tofd(i) = 0.0 - dvsfc_tofd(i) = 0.0 - tauf_ogw(i) = 0.0 -! - zmtb(i) = -99. - zlwb(i) = -99. - zogw(i) = -99. - ipt(i) = 0 - enddo -! print *, maxval(hprime), maxval(elvmax), ' check hprime -elevmax ugwp_oro' -! -! 3-part of oro-effects + ked_oro -! - do k=1, levs - do i=1, im - axz(i,k) = 0.0 - ayz(i,k) = 0.0 - edis(i,k) = 0.0 - kdis(i,k) = 0.0 - krf2d(i,k) = 0.0 - tauz_ogw(i,k) = 0.0 - axmtb(i:,k) = 0.0 - axlwb(i,k) = 0.0 - axtms(i,k) = 0.0 - enddo - enddo - -! -! optional diag 3-parts of drag: [tx_ogw, tx_mtb, tx_lee] -! -! ----do we have orography for mtb and gwd calculation points ? -! - npt = 0 - do i = 1,im - if ( (elvmax(i) > hminmt) .and. (hprime(i) > hpmin) ) then - npt = npt + 1 - ipt(npt) = i - - endif - enddo - if (npt == 0) return ! no ororgraphy ====> gwd/mb calculation done - -! allocate(iwklm(npt), idxzb(npt), kreflm(npt)) - allocate( k_elev(npt), k_mtb(npt), k_ogw(npt), k_lee(npt), k_tofd(npt)) - do i=1,npt - k_ogw (i) = 2 - k_tofd(i) = 2 - k_lee (i) = 2 - k_mtb(i) = 0 - k_elev(i) = 2 - enddo -! -! controls through: use ugwp_oro_init -! main ORO-loop sigfac = n*sigma = [1.5, 2, 2.5, 4]*hprime -! - - - do i = 1, npt -! - j = ipt(i) - - elvpd = elvmax(j) - elvp = min (elvpd + sigfac * hprime(j), hncrit) - - sigma = orostat(j,13) - gamm = orostat(j,12) - theta = orostat(j,11)*deg_to_rad - - if (sigma == 0.0 ) then - sigma = sigma_std - gamm = gamm_std - theta = 0.0 - endif - - oc = orostat(j,2) - oa4(1) = orostat(j,3) - oa4(2) = orostat(j,4) - oa4(3) = orostat(j,5) - oa4(4) = orostat(j,6) - clx4(1) = orostat(j,7) - clx4(2) = orostat(j,8) - clx4(3) = orostat(j,9) - clx4(4) = orostat(j,10) -! -! do column-based diagnostics "more-efficient" for oro-places -! - - do k=1,levs - up(k) = u(j,k) - vp(k) = v(j,k) - tp(k) = tkin(j,k) - qp(k) = q(j,k) - dp(k) = delp(j,k) - - zpm(k) = gzmid(j,k) * rgrav - pmid1(k) = pmid(j,k) - pex(k) = pexner(j,k) - enddo - do k=1,levs+1 - zpi(k) = gzint(j,k) * rgrav - pint1(k) = pint(j,k) - enddo -! -! elvp- k-index: iwklm k_elvp = index for elvmax + 4*hprime, "elevation index" -! GFS-2017 - do k=1, levs-1 - if (elvp <= zpi(k+1) .and. elvp > zpi(k)) then - k_elev(i) = k+1 !......simply k+1 next interface level - exit - endif - enddo -! if (elvp .ge. 300. ) then -! write(6,333) elvp, zpi(1), elvpd, hprime(j), sigfac, hncrit -! pause -! endif -!333 format(6(3x, F10.3)) -! -! SSO effects: TOFD-drag/friction coefficients can be calculated -! - sigflt = hprime(j)*0.01 ! turb SSo(j) ...small-scale orography < 2-5 km .... - zpbl = hpbl(j) - - call ugwp_tofd1d(levs, sigflt, elvPd, zpi(1), zpbl, up, vp, zpm, & - utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1, levs - krf2d(j,k) = krf_tofd1(k) - axtms(j,k) = utofd1(k) -!------- -! nullify ORO-tendencies -! - drmtb(k) = 0.0 - drlee(k) = 0.0 - drtau(k) = 0.0 - drlow(k) = 0.0 - enddo - -!------- -! -! levels of k_mtb(i)/mtb + kdswj/dwlee + krefj/ogwd inside next "subs" -! zmtb, zlwb, zogw -! drmtb, drlow/drlee, drogw -!------- -! -! mtb : drmtb => 1-st order friction as well as TurbulentOro-Drag -! - call ugwp_drag_mtb( k_elev(i), levs, & - elvpd, elvp, hprime(j), sigma, theta, oc, oa4, clx4, gamm, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, k_mtb(i), drmtb, taumtb(j)) - - axmtb(j,1:levs) = drmtb(1:levs)*up(1:levs) -! -! print * , k_elev(i), k_mtb(i) , taumtb(j)*1.e3, ' k_elev, k_mtb , taumtb ' -! -! tautot = taulee+tauogw + rho*drlee = -d[taulee(z)]/dz -! - - - call ugwp_taub_oro(levs, k_mtb(i), kxw, taumtb(j), fcor(j), & - hprime(j) , sigma, theta, oc, oa4, clx4, gamm, elvp, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, xn, yn, umag, & - tautot(j), tauogw(j), taulee(j), drlee, tau_src, & - kxridge, kdswj, krefj, kotr) - -! print *, k_mtb(i), kxw, taumtb(j), fcor(j),hprime(j), ' af ugwp_taub_oro ' -! print *, kdswj, krefj, kotr, ' kdswj, krefj, kotr ' - - - tauf_ogw(j) = tautot(j) - axlwb(j,1:levs) = drlee(1:levs) - - if ( k_mtb(i) > 0) zmtb(j) = zpi(k_mtb(i))- zpi(1) - if ( krefj > 0) zogw(j) = zpi(krefj) - zpi(1) - if ( kdswj > 0) zlwb(j) = zpi(kdswj) - zpi(1) -! if ( k_mtb(i) > 0 .and. zmtb(j) > zogw(j)) print *, ' zmtb > zogw ', zmtb(j), zogw(j) -! -! tau: tauogw, kxw/kxridge ATTENTION c2f2(j) = fcor(j)*fcor(j)/kxridge/kxridge -! - if ( (krefj > 1) .and. ( abs(tauogw(j)) > 0.) ) then -! - call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & - fcor(j), kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & - xn, yn, umag, drtau, kdis_oro) -! - else - drtau = 0. - endif - - tauz_ogw(j,1:levs) = tau_src(1:levs) - - r_cpdt = rcpd2/dtp -! -! - do k = 1,levs -! -! project to x-dir & y=dir and do diagnostics -! & apply limiters and output separate oro-effects -! - drlow(k) = drtau(k) + drlee(k) - acc_lim = min(abs(drlow(k)), max_axyz) - drlow(k) = sign(acc_lim, drlow(k)) - - dtaux = drlow(k) * xn + utofd1(k) - dtauy = drlow(k) * yn + vtofd1(k) - - eng0 = up(k)*up(k)+vp(k)*vp(k) - eng1 = 0.0 -! - if (k < k_mtb(i) .and. drmtb(k) /= 0 ) then - loss = 1.0 / (1.0+drmtb(k)*dtp) - mtb_fric = drmtb(k)*loss -! - mbx = mtb_fric * up(k) - mby = mtb_fric * vp(k) -! - ayz(j,k) = -mby !+ ayz(j,k) - axz(j,k) = -mbx !+ axz(j,k) -! - eng1 = eng0*loss*loss +eng1 - dusfc(j) = dusfc(j) - mbx * dp(k) - dvsfc(j) = dvsfc(j) - mby * dp(k) - endif -! - ayz(j,k) = dtauy + ayz(j,k) - axz(j,k) = dtaux + axz(j,k) -! - tx1 = u(j,k) + dtaux*dtp - tx2 = v(j,k) + dtauy*dtp - eng1 = tx1*tx1 + tx2*tx2 + eng1 - - dusfc(j) = dusfc(j) + dtaux * dp(k) - dvsfc(j) = dvsfc(j) + dtauy * dp(k) - - edis(j,k) = max(eng0-eng1, 0.0) * r_cpdt !+ epstofd1(k) - kdis(j,k) = min(kdis_oro(k), max_kdis ) - - enddo -! - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) -! -! oro-locations -! - enddo ! ipt - oro-loop .... "fraction of Land" in the grid box - deallocate(k_elev, k_mtb, k_ogw, k_lee, k_tofd ) -! - end subroutine ugwp_oro -! -! - subroutine gw_solver_linsatdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs - integer :: me, kdt, nw, naz, nf_src - real :: dtp - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, & - q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, & - bn2i, bvi, rhoi - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real, dimension(levs+1) :: ked1, tau1 - real :: chm, ss - real, parameter :: dsp = 1./20. - logical :: pfirst=.true. - - save pfirst -128 Format (2x, I4, 4(2x, F10.3)) - -! do i=1, nw -! spf(i) = exp(-Ch(i)*dsp) -! enddo -! ss = sum(spf) -! spf(1:nw) = spf(1:nw)/ss - - if (pfirst ) then - j = 1 - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j) - print * - chm = 0. - do i=1, nw - write(6, 128) i, spf(i), taub_spect(i)*1.e3, ch(i), ch(i)-chm - chm = ch(i) - enddo - - print * - !pause - endif - - do j=1,im - if (if_src(j) == 1) then -! -! compute GW-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! H2O-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) * rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k) * rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j)/rhoi(ksrc) - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' tempi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(u1), minval(u1) , ' ++++ u1 ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(v1), minval(v1) , ' ++++ v1 ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! - call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, & - ch, xaz, yaz, fcor(j), c2f2(j), dp, & - zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, & - ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' rhoi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - endif - - enddo - pfirst = .false. -! -! spectral solver for discrete spectra of GWs in N-azimiths -! Linear saturation with background dissipation -! - end subroutine gw_solver_linsatdis -! - subroutine gw_solver_wmsdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) -! use para_taub, only : tau_ex - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs, me, kdt, nw, naz, nf_src - real :: dtp - - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real,dimension(levs+1) :: ked1, tau1 - real :: tau_ex - -! print *, nf_src, 'nf_src ... gw_solver_wmsdis ' -! print *, if_src, 'if_src ... gw_solver_wmsdis ' - - do j=1,im - if (if_src(j) == 1) then -! -! compute gw-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! h2o-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) *rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k)*rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! -! any extras bkg-arrays -! - ksrc = klev(j) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! more work for spectral setup for different "slopes" -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tau_ex = taub(j) - taub_spect(1:nw) = spf(1:nw)/rhoi(ksrc) *tau_ex ! check it ....*tau_ex(j) - -! -! call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) -! -! print *, ' bf ugwp_wmsdis_naz ksrc', ksrc, zmid(ksrc) - - call ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, tau_ex, ch, xaz, yaz, & - fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, & - rho, ui, vi, ti, kvg, ktg, krad, kion, bn2i, bvi, & - rhoi, ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - -! print *, ' after ugwp_wmsdis_naz ksrc', ksrc, zint(ksrc) - -! subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & -! fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked) - -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - - endif - - enddo -! -! ugwp_wmsdis_naz everything similar to linsat , except spectral saturation -! -! - return - end subroutine gw_solver_wmsdis -! -! - subroutine rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, u, v, ax, ay, eps) - use ugwp_common, only : rcpd2 - - implicit none - - integer :: im, levs, levs_rf - real :: dtp - real, dimension(levs) :: rfdis, rfdist - real, dimension(im, levs) :: u, v, ax, ay, eps - real :: ud, vd, rdtp - integer :: i, k - - rdtp = 1.0 / dtp - - do k= levs_rf, levs - do i=1,im - ud = rfdis(k)*u(i,k) - vd = rfdis(k)*u(i,k) - ax(i,k) = rfdist(k)*u(i,k) - ay(i,k) = rfdist(k)*v(i,k) - eps(i,k) = rcpd2*(u(i,k)*u(i,k) +v(i,k)*v(i,k) -ud*ud -vd*vd) - enddo - enddo - end subroutine rf_damp -! diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index c345a8e85..4a8b97590 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -1,473 +1,5 @@ - subroutine ugwp_triggers - implicit none - write(6,*) ' physics-based triggers for UGWP ' - end subroutine ugwp_triggers -! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - use ugwp_common , only : deg_to_rad - - implicit none - integer :: nx, ny - real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: earth_r, ra1, ra2, dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - integer :: j -! -! specify common constants and -! geometric factors to compute deriv-es etc ... -! coriolis coslat tan etc... -! - earth_r = 6370.e3 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 -! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) -! - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo -! - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos -! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) - - dlat = ra1 / (dy+dy) - - divJp = dlat*cosv - divJM = dlat*cosv -! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) -! - return - end SUBROUTINE subs_diag_geo -! - subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! compute for each Vert-column: grad(V) -! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Vx(nx, ny), Vy(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) - - end subroutine get_xy_pt - - subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) -! -! compute for each Vert-column: grad(V) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Divjp(ny), Divjm(ny) - real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) -!~~~~~~~~~~~~~~~~~~~~ -! 1/cos*d(vcos)/dy -!~~~~~~~~~~~~~~~~~~~~ - do j=2, ny-1 - Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) - enddo - Vyd(:, 1) = Vyd(:,2) - Vyd(:,ny) = Vyd(:,ny-1) - - end subroutine get_xyd_wind - - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_fgf -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - - enddo - end subroutine trig3d_fjets - - subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_okw -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2, d1 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 - W2 = (Vx - Uyd)*(Vx - Uyd) - D1 = Ux + Vyd - trig3d_okw(:,:,k) = W1 -W2 -! trig3d_okw(:, :, k) =S2 -W2 -! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean -! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk - enddo - end subroutine trig3d_okubo -! - subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_conv - - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - integer :: k - end subroutine trig3d_dconv - - subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & - U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - trig3d_okw, trig3d_fgf, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! -! reversed ??? Hyai, Hybi , pmid -! - real, dimension(nz+2) :: Hyai, Hybi - real, dimension(nz+1) :: Hyam, Hybm -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS, HS - real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - real :: dzkm, zkm - integer :: k -!================================================================================== -! fgf and OW-triggers -! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! -! -!=================================================================================== - - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) - call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) -!===================================================================================================== -! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d -! -! Bulk momentum flux=/ 0 and levels for launches -! -!===================================================================================================== - 111 format(i6, 4(3x, F8.3), ' trigger-grid ') - - do k=1, nz-1 - zkm = -7.*alog(pmid(k)*1.e-3) - dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) - write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' - enddo - - end subroutine cires_3d_triggers -!================================================================================== -! tot-flux launch 0 or 1 # of Launches -! specify time-dep bulk sources: taub, klev, if_src, nf_src -! -!================================================================================== - subroutine get_spectra_tau_convgw & - (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) ! -! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function -! - integer :: nw, im, levs - integer,dimension(im,3) :: icld - real, dimension(im, levs) :: dcheat, scheat - real, dimension(im) :: precip, xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! -! locals - real, parameter :: precip_max = 100. ! mm/day - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - - integer :: i, k, klow, ktop, kmid - real :: dtot, dmax, daver -! - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - do i=1, im - klow = icld(i,1) - ktop = icld(i,2) - kmid= icld(i,3) - if (klow == -99 .and. ktop == -99) then - cycle - else - klev(i) = ktop - k = klow - klev(i) = k - dmax = abs(dcheat(i,k) + scheat(i,k)) - do k=klow+1, ktop - dtot =abs(dcheat(i,k) + scheat(i,k)) - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! -! klev as max( dcheat(i,k) + scheat) -! vertical width of conv-heating -! -! counts/triiger=1 & taub(i) -! - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_amp* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! 100 mb launch and MERRA-2 slat-forcing -! - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo - -! with info on precip/clouds/dc_heat create Bulk -! taub(im), klev(im) -! -! print *, ' get_spectra_tau_convgw ' - end subroutine get_spectra_tau_convgw -! - subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_fgf -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1.0 / float(kwidth) - tau_min = tau_amp*fnorm - do i=1, im -! -! only trop-c fjets so find max(trig_fgf) => klev -! use abs-values to scale tau_amp -! - - k = klow - klev(i) = k - dmax = abs(trig_fgf(i,k)) - kex = 0 - if (dmax >= tlim_fgf) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_fgf(i,k)) - if (dtot >= tlim_fgf) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo - - if (dmax .ge. tlim_fgf) then - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! print *, ' get_spectra_tau_nstgw ' - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo -! - end subroutine get_spectra_tau_nstgw -! - subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_okw -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1./float(kwidth) - tau_min = tau_amp*fnorm - print *, ' get_spectra_tau_okwgw ' - do i=1, im - k = klow - klev(i) = k - dmax = abs(trig_okw(i,k)) - kex = 0 - if (dmax >= tlim_okw) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! - if (dmax >= tlim_okw) then - nf_src = nf_src + 1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo - print *, ' get_spectra_tau_okwgw ' - end subroutine get_spectra_tau_okw -! -! -! -!>\ingroup cires_ugwp_run -!> @{ -!! -!! - subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) + subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -498,9 +30,9 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5_tamp + end subroutine slat_geos5_tamp_v0 - subroutine slat_geos5(im, xlatdeg, tau_gw) + subroutine slat_geos5_v0(im, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -537,9 +69,10 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5 - subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common , only : pi2 + end subroutine slat_geos5_v0 +! + subroutine init_nazdir_v0(naz, xaz, yaz) + use ugwp_common_v0 , only : pi2 implicit none integer :: naz real, dimension(naz) :: xaz, yaz @@ -563,4 +96,4 @@ subroutine init_nazdir(naz, xaz, yaz) xaz(4) = 0.0 yaz(4) =-1.0 !S endif - end subroutine init_nazdir + end subroutine init_nazdir_v0 diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 deleted file mode 100644 index 8cfd57cb7..000000000 --- a/physics/cires_ugwp_triggers_v1.F90 +++ /dev/null @@ -1,584 +0,0 @@ -module cires_ugwp_triggers_v1 - - -contains - - - subroutine ugwp_triggers - implicit none - write(6,*) ' physics-based triggers for UGWP ' - end subroutine ugwp_triggers -! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, earth_r, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - implicit none - integer :: nx, ny - real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: ra1, ra2, dx, dy, dlat - real :: con_pi, earth_r - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - integer :: j - real :: deg_to_rad -! -! specify common constants and -! geometric factors to compute deriv-es etc ... -! coriolis coslat tan etc... -! - deg_to_rad = con_pi/180.0 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 -! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) -! - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo -! - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos -! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) - - dlat = ra1 / (dy+dy) - - divJp = dlat*cosv - divJM = dlat*cosv -! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) -! - return - end SUBROUTINE subs_diag_geo -! - subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! compute for each Vert-column: grad(V) -! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Vx(nx, ny), Vy(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) - - end subroutine get_xy_pt - - subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) -! -! compute for each Vert-column: grad(V) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Divjp(ny), Divjm(ny) - real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) -!~~~~~~~~~~~~~~~~~~~~ -! 1/cos*d(vcos)/dy -!~~~~~~~~~~~~~~~~~~~~ - do j=2, ny-1 - Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) - enddo - Vyd(:, 1) = Vyd(:,2) - Vyd(:,ny) = Vyd(:,ny-1) - - end subroutine get_xyd_wind - - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & - con_pi, con_rerth, pmid, trig3d_fgf) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_fgf -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - - enddo - end subroutine trig3d_fjets - - subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_okw -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2, d1 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 - W2 = (Vx - Uyd)*(Vx - Uyd) - D1 = Ux + Vyd - trig3d_okw(:,:,k) = W1 -W2 -! trig3d_okw(:, :, k) =S2 -W2 -! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean -! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk - enddo - end subroutine trig3d_okubo -! - subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_conv - - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - integer :: k - end subroutine trig3d_dconv - - subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & - U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - con_pi, con_rerth, trig3d_okw, trig3d_fgf, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! -! reversed ??? Hyai, Hybi , pmid -! - real, dimension(nz+2) :: Hyai, Hybi - real, dimension(nz+1) :: Hyam, Hybm -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS, HS - real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - real :: dzkm, zkm - integer :: k -!================================================================================== -! fgf and OW-triggers -! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! -! -!=================================================================================== - - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & - con_pi, con_rerth, pmid, trig3d_fgf) - call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) - call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) -!===================================================================================================== -! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d -! -! Bulk momentum flux=/ 0 and levels for launches -! -!===================================================================================================== - 111 format(i6, 4(3x, F8.3), ' trigger-grid ') - - do k=1, nz-1 - zkm = -7.*alog(pmid(k)*1.e-3) - dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) - write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' - enddo - - end subroutine cires_3d_triggers -!================================================================================== -! tot-flux launch 0 or 1 # of Launches -! specify time-dep bulk sources: taub, klev, if_src, nf_src -! -!================================================================================== - subroutine get_spectra_tau_convgw & - (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) -! -! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function -! - integer :: nw, im, levs - integer,dimension(im,3) :: icld - real, dimension(im, levs) :: dcheat, scheat - real, dimension(im) :: precip, xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! -! locals - real, parameter :: precip_max = 100. ! mm/day - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - - integer :: i, k, klow, ktop, kmid - real :: dtot, dmax, daver -! - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - do i=1, im - klow = icld(i,1) - ktop = icld(i,2) - kmid= icld(i,3) - if (klow == -99 .and. ktop == -99) then - cycle - else - klev(i) = ktop - k = klow - klev(i) = k - dmax = abs(dcheat(i,k) + scheat(i,k)) - do k=klow+1, ktop - dtot =abs(dcheat(i,k) + scheat(i,k)) - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! -! klev as max( dcheat(i,k) + scheat) -! vertical width of conv-heating -! -! counts/triiger=1 & taub(i) -! - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_amp* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! 100 mb launch and MERRA-2 slat-forcing -! - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo - -! with info on precip/clouds/dc_heat create Bulk -! taub(im), klev(im) -! -! print *, ' get_spectra_tau_convgw ' - end subroutine get_spectra_tau_convgw -! - subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_fgf -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1.0 / float(kwidth) - tau_min = tau_amp*fnorm - do i=1, im -! -! only trop-c fjets so find max(trig_fgf) => klev -! use abs-values to scale tau_amp -! - - k = klow - klev(i) = k - dmax = abs(trig_fgf(i,k)) - kex = 0 - if (dmax >= tlim_fgf) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_fgf(i,k)) - if (dtot >= tlim_fgf) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo - - if (dmax .ge. tlim_fgf) then - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! print *, ' get_spectra_tau_nstgw ' - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo -! - end subroutine get_spectra_tau_nstgw -! - subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_okw -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1./float(kwidth) - tau_min = tau_amp*fnorm - print *, ' get_spectra_tau_okwgw ' - do i=1, im - k = klow - klev(i) = k - dmax = abs(trig_okw(i,k)) - kex = 0 - if (dmax >= tlim_okw) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! - if (dmax >= tlim_okw) then - nf_src = nf_src + 1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo - print *, ' get_spectra_tau_okwgw ' - end subroutine get_spectra_tau_okw -! -! -! -!>\ingroup cires_ugwp_run -!> @{ -!! -!! - subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: tau_amp, xlatdeg(im), tau_gw(im) - real :: latdeg, flat_gw, tem - integer :: i - -! -! if-lat -! - do i=1, im - latdeg = abs(xlatdeg(i)) - if (latdeg < 15.3) then - tem = (latdeg-3.0) / 8.0 - flat_gw = 0.75 * exp(-tem * tem) - if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 - elseif (latdeg < 31.0 .and. latdeg >= 15.3) then - flat_gw = 0.10 - elseif (latdeg < 60.0 .and. latdeg >= 31.0) then - tem = (latdeg-60.0) / 23.0 - flat_gw = 0.50 * exp(- tem * tem) - elseif (latdeg >= 60.0) then - tem = (latdeg-60.0) / 70.0 - flat_gw = 0.50 * exp(- tem * tem) - endif - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5_tamp_v1 - - subroutine slat_geos5(im, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: xlatdeg(im) - real :: tau_gw(im) - real :: latdeg - real, parameter :: tau_amp = 100.e-3 - real :: trop_gw, flat_gw - integer :: i -! -! if-lat -! - trop_gw = 0.75 - do i=1, im - latdeg = xlatdeg(i) - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) - if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then - flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5 - subroutine init_nazdir(con_pi, naz, xaz, yaz) - implicit none - real :: con_pi - integer :: naz - real, dimension(naz) :: xaz, yaz - integer :: idir - real :: phic, drad - real :: pi2 - pi2 = 2.0*con_pi - drad = pi2/float(naz) - if (naz.ne.4) then - do idir =1, naz - Phic = drad*(float(idir)-1.0) - xaz(idir) = cos(Phic) - yaz(idir) = sin(Phic) - enddo - else -! if (naz.eq.4) then - xaz(1) = 1.0 !E - yaz(1) = 0.0 - xaz(2) = 0.0 - yaz(2) = 1.0 !N - xaz(3) =-1.0 !W - yaz(3) = 0.0 - xaz(4) = 0.0 - yaz(4) =-1.0 !S - endif - end subroutine init_nazdir - - -end module cires_ugwp_triggers_v1 - diff --git a/physics/cires_ugwp_utils.F90 b/physics/cires_ugwp_utils.F90 deleted file mode 100644 index 63a5b3238..000000000 --- a/physics/cires_ugwp_utils.F90 +++ /dev/null @@ -1,152 +0,0 @@ -! - subroutine um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, bn2, uhm, vhm, bn2hm, rhohm) -! - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - implicit none -! -! mass-averaged variables between klow-ktop -! - integer, intent(in) :: nz, klow, ktop - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: pint, zpi - real, dimension(nz), intent(out) :: bn2 - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp, rhm,dphm - - real, intent(out) :: uhm, vhm, bn2hm, rhohm - - integer :: k -! - dphm = 0.0 !pint(k+1)-pint(k)) - - uhm = 0.0 ! dphm*u1(k) - vhm = 0.0 ! dphm*v1(k) - rhm = 0.0 ! - bn2hm = 0.0 ! -! - do k=klow, ktop - vtj = tp(k) * (1.+fv*qp(k)) - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rhok = rdi * pmid(k) / vtj ! density kg/m**3 - rdz = 1.0 / (zpm(k+1)-zpm(k)) -! dry -! bnv2 = grav * (rdz * ( tp(k+1)-tp(k)) +grcp) /tp(k) -! -! wet -! - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtk -! if (bnv2 < 0) print *, k, bnv2, ' bnv2 < 0 ', klow, ktop - bnv2 = max(bnv2, bnv2min ) - dzp = pint(k+1)-pint(k) - - dphm = dphm + dzp - uhm = uhm + up(k)*dzp - vhm = vhm + vp(k)*dzp - rhm = rhm + rhok*dzp - bn2hm = bn2hm + bnv2 * dzp - bn2(k) = bnv2 - enddo - - uhm = uhm/dphm - vhm = vhm/dphm - rhm = rhm/dphm - bn2hm = bn2hm/dphm - rhohm = rhm/dphm -! -! print *, ' MF-BV ', bn2hm, bn2(ktop), bn2(klow) -! - end subroutine um_flow -! -! - subroutine mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - - implicit none - - integer :: levs - real, dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(levs+1) :: pint, rho, zpi - real, dimension(levs) :: zdelpi, zdelpm - real :: zul, bvl - real, dimension(levs+1) :: ui, vi, bn2i, bvi, rhoi, ti, qi - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp - real :: vtji - integer :: k -! -! get interface values from surf to top -! - do k=2,levs - vi(k) = 0.5 *(vp(k-1) + vp(k)) - ui(k) = 0.5 *(up(k-1) + up(k)) - ti(k) = 0.5 *(tp(k-1) + tp(k)) - qi(k) = 0.5 *(qp(k-1) + qp(k)) - enddo - - k=1 - ti(k) = tp(k) - ui(k) = up(k) - vi(k) = vp(k) - qi(k) = qp(k) - k= levs - ti(k+1) = tp(k) - ui(k+1) = up(k) - vi(k+1) = vp(k) - qi(k+1)=qp(k) - - do k=1,levs-1 - vtj = tp(k) * (1.+fv*qp(k)) - vtji = ti(k) * (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj ! density kg/m**3 - rhoi(k) = rdi * pint(k) / vtji - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rdz = 1. / ( zpm(k+1)-zpm(k)) - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtji - bn2i(k) = max(bnv2, bnv2min ) - bvi(k) = sqrt( bn2i(k) ) - vtk = vtkp - enddo - k = levs - vtj = tp(k) ! * (1.+fv*qp(k)) - vtji = ti(k) !* (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj - rhoi(k) = rdi * pint(k) / vtji - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) - k = levs+1 - rhoi(k) = rdi * pint(k) / ti(k) - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) -! do k=1,levs -! write(6, 121) k, zpm(k)*1.e-3, zpi(k)*1.e-3, bvi(k), rho(k), rhoi(k) -! enddo - 121 format(i5, 2x, 3(2x, F10.3), 2(2x, E10.3)) - - end subroutine mflow_tauz - -! - subroutine get_unit_vector(u, v, u_n, v_n, mag) - implicit none - real, intent(in) :: u, v - real, intent(out) :: u_n, v_n, mag -! - - mag = sqrt(u*u + v*v) - - if (mag > 0.0) then - u_n = u/mag - v_n = v/mag - else - u_n = 0. - v_n = 0. - end if - - end subroutine get_unit_vector -! diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/cires_ugwpv1_initialize.F90 new file mode 100644 index 000000000..ad39def17 --- /dev/null +++ b/physics/cires_ugwpv1_initialize.F90 @@ -0,0 +1,828 @@ +!=============================== +! cu-cires ugwp-scheme +! initialization of selected +! init gw-solvers (1,2,3,4) +! init gw-source specifications +! init gw-background dissipation +!============================== +! +! Part-0 specifications of common constants, limiters and "criiical" values +! +! + + module ugwp_common +! + use machine, only : kind_phys + + implicit none + + real(kind=kind_phys) :: pi, pi2, pih, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: arad, p0s + real(kind=kind_phys) :: grav, grav2, rgrav, rgrav2 + real(kind=kind_phys) :: cpd, rd, rv, fv + real(kind=kind_phys) :: rdi, rcpd, rcpd2 + + real(kind=kind_phys) :: gor, gr2, grcp, gocp, rcpdl, grav2cpd + real(kind=kind_phys) :: bnv2min, bnv2max + real(kind=kind_phys) :: dw2min, velmin, minvel + real(kind=kind_phys) :: omega1, omega2, omega3 + real(kind=kind_phys) :: hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm + real(kind=kind_phys) :: mkzmin, mkz2min, mkzmax, mkz2max, cdmin + real(kind=kind_phys) :: rcpdt + +! real(kind=kind_phys), parameter :: grav2 = grav + grav +! real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav +! real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd +! real(kind=kind_phys), parameter :: gor = grav/rd, rcpdt = 1./(cp*dtp) + +! real(kind=kind_phys), parameter :: gr2 = grav*gor +! real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp +! real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g +! real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp +! real(kind=kind_phys), parameter :: pi2 = 2.*pi, pih = .5*pi +! real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 +! +! real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) +! real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) +! real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 +! real(kind=kind_phys), parameter :: omega1 = pi2/86400., omega2 = 2.*omega1, omega3 = 3.*omega1 +! +! real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp +! real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin +! real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax +! real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax +! real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), +! real(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. +! real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 +! real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 +! real(kind=kind_phys), parameter :: arad = 6370.e3 + + end module ugwp_common + + subroutine init_nazdir(naz, xaz, yaz) + + use machine, only : kind_phys + use ugwp_common, only : pi2 + + implicit none + + integer :: naz + real(kind=kind_phys), dimension(naz) :: xaz, yaz + integer :: idir + real(kind=kind_phys) :: phic, drad + + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir +! +! +!=================================================== +! +!Part-1 init => wave dissipation + RFriction +! +!=================================================== + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! + use machine , only : kind_phys + use ugwp_common, only : pih, pi + + implicit none + integer , intent(in) :: me, master + integer , intent(in) :: levs + real(kind=kind_phys), intent(in) :: zkm(levs), pmb(levs) ! in km-Pa + real(kind=kind_phys), intent(out), dimension(levs+1) :: kvg, ktg, krad, kion +! +!locals + data +! + integer :: k + real(kind=kind_phys), parameter :: vusurf = 2.e-5 + real(kind=kind_phys), parameter :: musurf = vusurf/1.95 + real(kind=kind_phys), parameter :: hpmol = 7.0 +! + real(kind=kind_phys), parameter :: kzmin = 0.1 + real(kind=kind_phys), parameter :: kturbo = 100. + real(kind=kind_phys), parameter :: zturbo = 130. + real(kind=kind_phys), parameter :: zturw = 30. + real(kind=kind_phys), parameter :: inv_pra = 3. !kt/kv =inv_pr +! + real(kind=kind_phys), parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days + real(kind=kind_phys) :: pa_alp = 750. ! super-RF parameters from FV3-dycore GFSv17/16 sett + real(kind=kind_phys) :: tau_alp = 10. ! days (750 Pa /10days) +! + real(kind=kind_phys), parameter :: kdrag = 1./86400./30. !parametrization for WAM ion drag as e-density function + real(kind=kind_phys), parameter :: zdrag = 100. + real(kind=kind_phys), parameter :: zgrow = 50. +! + real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag + real(kind=kind_phys) :: rf_fv3, rtau_fv3, ptop, pih_dlog +! + real(kind=kind_phys) :: ae1 ,ae2 +! + + ptop = pmb(levs) + rtau_fv3 = 1./86400./tau_alp + pih_dlog = pih/log(pa_alp/ptop) + + do k=1, levs + ae1 = zkm(k)/hpmol + vumol = vusurf*exp(ae1) + mumol = musurf*exp(ae1) + ae2 = -((zkm(k)-zturbo) /zturw)**2 + keddy = kturbo*exp(ae2) + + kvg(k) = vumol + keddy + ktg(k) = mumol + keddy*inv_pra + + krad(k) = alpha +! + ion_drag = kdrag +! + kion(k) = ion_drag! +! add Rayleigh_Super of FV3 for pmb < pa_alp +! + if (pmb(k) .le. pa_alp) then + rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 + krad(k) = krad(k) + rf_fv3 + kion(k) = kion(k) + rf_fv3 + + endif + +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) + enddo + + k= levs+1 + kion(k) = kion(k-1) + krad(k) = krad(k-1) + kvg(k) = kvg(k-1) + ktg(k) = ktg(k-1) + +! if (me == master) then +! write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ... init_global_gwdis' +! do k=1, levs, 1 +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) +! enddo +! endif +! +! 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) + + end subroutine init_global_gwdis +! +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init +! +!========================================================================= + module ugwp_oro_init + use machine , only : kind_phys + use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common, only : mkzmin, mkz2min + implicit none +! +! constants and "crirtical" values to run oro-mtb_gw physics +! +! + real(kind=kind_phys), parameter :: hncrit=9000. ! max value in meters for elvmax + real(kind=kind_phys), parameter :: hminmt=50. ! min mtn height (*j*) + real(kind=kind_phys), parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor + real(kind=kind_phys), parameter :: hpmax=2500.0 + real(kind=kind_phys), parameter :: hpmin=25.0 +! +! + real(kind=kind_phys), parameter :: minwnd=1.0 ! min wind component (*j*) + real(kind=kind_phys), parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + + + character(len=8) :: strver = 'gfs_2018' + character(len=8) :: strbase = 'gfs_2018' + + real(kind=kind_phys), parameter :: rimin=-10., ric=0.25 + + real(kind=kind_phys), parameter :: frmax=10., frc =1.0, frmin =0.01 + real(kind=kind_phys), parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real(kind=kind_phys), parameter :: gmax=1.0, veleps=1.0, factop=0.5! + real(kind=kind_phys), parameter :: efmin=0.5, efmax=10.0 + + real(kind=kind_phys), parameter :: rlolev=50000.0 + integer, parameter :: mdir = 8 + real(kind=kind_phys), parameter :: fdir=mdir/(8.*atan(1.0)) + real(kind=kind_phys), parameter :: zpgeo=2.*atan(1.0) + + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir + + real(kind=kind_phys), parameter :: odmin = 0.1, odmax = 10.0 + real(kind=kind_phys), parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm + real(kind=kind_phys), parameter :: fcrit_gfs = 0.7, fcrit_v1 = 0.7 + real(kind=kind_phys), parameter :: fcrit_mtb = 0.7 + + real(kind=kind_phys), parameter :: zbr_pi = zpgeo + real(kind=kind_phys), parameter :: zbr_ifs = zpgeo + +! + + real(kind=kind_phys), parameter :: kxoro=6.28e-3/200. ! + real(kind=kind_phys), parameter :: coro = 0.0 + integer,parameter :: nridge=2 + real(kind=kind_phys), parameter :: sigma_std=1./100., gamm_std=1.0 + + real(kind=kind_phys) :: cdmb ! scale factors for mtb + real(kind=kind_phys) :: cleff ! scale factors for orogw + + integer :: nworo ! number of waves + integer :: nazoro ! number of azimuths + integer :: nstoro ! flag for stochastic launch above SG-peak + + +!------------------------------------------------------------------------------ +! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS +! SA-option can be controlled by Integral limits of fluxes +! in B2004: klow = 0.003 1/m ~ 2km and kinf ~ 6.28/10/(Z1)~< 1 km => meters +! these limits can change strength of TOFD... choice of k0tr ~1/10 km (10km ~dx of C768) +! kmax = kdis_pbl +!------------------------------------------------------------------------------ + real(kind=kind_phys), parameter :: kmax = 6.28/(10.*25.) ! max k-tofd + real(kind=kind_phys), parameter :: k1tr = 6.28/(2100) ! max k-transition from -1.9/slope to -2.8/slope + real(kind=kind_phys), parameter :: kflt = 6.28/(18.e3) ! + real(kind=kind_phys), parameter :: k0tr = 6.28/(10.e3) ! min k-tofd + real(kind=kind_phys), parameter :: nk1tr = 2.8 + real(kind=kind_phys), parameter :: nk0tr = 1.9 + real(kind=kind_phys), parameter :: a1_tofd = kflt ** nk1tr *1.e3 + real(kind=kind_phys), parameter :: a2_tofd = k1tr ** (nk0tr-nk1tr) + real(kind=kind_phys), parameter :: fix_tofd = 2.* 0.005 * 12 *0.6 !value= 0.072 +! +! B2004 scheme is based on the empirical vertical profile of the tofd divergence: +! Ax_tofd(Z)=exp(-[Z/ze_tofd]^3/2) / Z^1.2..... +! TOFD-flux/TMS-flux must dissipate due to PBL-diffusion with spectral damping +! Here we can enhance TOFD-impact by selecting k0tr and kmax limits +! as functions of resolution and PBL-dissipation +! + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real(kind=kind_phys), parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real(kind=kind_phys), parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters, 1.5 km + real(kind=kind_phys), parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real(kind=kind_phys), parameter :: ztop_tofd = 3.*ze_tofd ! no TOFD > this height 4.5 km +!------------------------------------------------------------------------------ +! + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: cdmbX + real(kind=kind_phys) :: kxw + real(kind=kind_phys) :: effac ! it is analog of cdmbgwd(2) for GWs, off for now +!-----------------------------! GFS-setup for cdmb & cleff +! cdmb = 4.0 * (192.0/IMX) +! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) +! + real(kind=kind_phys), parameter :: lonr_refmb = 4.0 * 192.0 + real(kind=kind_phys), parameter :: lonr_refgw = 192.0 + real(kind=kind_phys), parameter :: cleff_ref = 0.5e-5 ! 1256 km = 10 * 125 km ??? + +! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + + cdmb = cdmbX + cleff = cleff_ref * sqrt(lonr_refgw/float(lonr)) !* effac +! + end subroutine init_oro_gws +! + + end module ugwp_oro_init +! ========================================================================= +! +! ugwp_conv_init +! +!========================================================================= + module ugwp_conv_init + + use machine , only : kind_phys + + + implicit none + real(kind=kind_phys) :: eff_con ! scale factors for conv GWs + integer :: nwcon ! number of waves + integer :: nazcon ! number of azimuths + integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud + real(kind=kind_phys) :: con_dlength + real(kind=kind_phys) :: con_cldf + + real(kind=kind_phys), parameter :: cmin = 5 !2.5 + real(kind=kind_phys), parameter :: cmax = 95. !82.5 + real(kind=kind_phys), parameter :: cmid = 22.5 + real(kind=kind_phys), parameter :: cwid = cmid + real(kind=kind_phys), parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real(kind=kind_phys), parameter :: mstar = 6.28e-3/2. ! 2km + real(kind=kind_phys) :: dc + + real(kind=kind_phys), allocatable :: ch_conv(:), spf_conv(:) + real(kind=kind_phys), allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) +! + use ugwp_common, only : pi2, arad + + implicit none + + + integer :: nwaves, nazdir, nstoch + integer :: lonr +! +! ccpp +! + + real(kind=kind_phys) :: kxw, effac + real(kind=kind_phys) :: work1 = 0.5 + real(kind=kind_phys) :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = pi2*arad/float(lonr) +! +! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" +! + if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) + if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) + if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) + if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) +! +! we may use different spectral "shapes" +! for example FVS-93 "Desabeius" +! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail +! + do k = 1,nwaves + chk = cmin + (k-1)*dc + tn4 = (mstar*chk)**4 + ch_conv(k) = chk + spf_conv(k) = bns4*chk/(bns4+tn4) + enddo + + snorm = sum(spf_conv) + spf_conv = spf_conv/snorm*1.5 + + call init_nazdir(nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init +!========================================================================= +! +! ugwp_fjet_init +! +!========================================================================= + + module ugwp_fjet_init + use machine , only : kind_phys + + + + implicit none + real(kind=kind_phys) :: eff_fj ! scale factors for conv GWs + integer :: nwfj ! number of waves + integer :: nazfj ! number of azimuths + integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud +! + real(kind=kind_phys), parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_fjet(:) , spf_fjet(:) + real(kind=kind_phys), allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac,lonr, kxw) + + use ugwp_common, only : pi2, arad + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: kxw, effac , chk + + integer :: k + + nwfj = nwaves + nazfj = nazdir + nstfj = nstoch + eff_fj = effac + + if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) + if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) + if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) + if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_fjet(k) = chk + spf_fjet(k) = 1.0 + enddo + call init_nazdir(nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init +! +!========================================================================= +! +! + module ugwp_okw_init +!========================================================================= + use machine , only : kind_phys + + implicit none + + real(kind=kind_phys) :: eff_okw ! scale factors for conv GWs + integer :: nwokw ! number of waves + integer :: nazokw ! number of azimuths + integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud +! + real(kind=kind_phys), parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_okwp(:), spf_okwp(:) + real(kind=kind_phys), allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + + + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + use ugwp_common, only : pi2, arad + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: kxw, effac , chk + + integer :: k + + nwokw = nwaves + nazokw = nazdir + nstokw = nstoch + eff_okw = effac + + if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) + if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) + if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) + if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_okwp(k) = chk + spf_okwp(k) = 1. + enddo + + call init_nazdir(nazdir, xaz_okwp, yaz_okwp) +! + end subroutine init_okw_gws + + end module ugwp_okw_init + +!=============================== end of GW sources +! +! init specific gw-solvers (1,2,3,4) +! +!=============================== +! Part -3 init wave solvers +!=============================== + + module ugwp_lsatdis_init + use machine , only : kind_phys + implicit none + + integer :: nwav, nazd + integer :: nst + real(kind=kind_phys) :: eff + integer, parameter :: incdim = 4, iazdim = 4 +! + contains + + subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + + implicit none +! + integer :: me, master + integer :: nwaves, nazdir + integer :: nstoch + real(kind=kind_phys) :: effac + logical :: do_physb + real(kind=kind_phys) :: kxw +! +!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces +! are not actibve +! + integer :: inc, jk, jl, iazi, i, j, k + + if( nwaves == 0 .or. nstoch == 1 ) then +! redefine from the default + nwav = incdim + nazd = iazdim + nst = 0 + eff = 1.0 + else +! from input_nml multi-wave spectra + nwav = nwaves + nazd = nazdir + nst = nstoch + eff = effac + endif +! + end subroutine initsolv_lsatdis +! + end module ugwp_lsatdis_init +! +! + module ugwp_wmsdis_init + + use machine , only : kind_phys + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 + use ugwp_common, only : bnv2max, bnv2min, minvel + use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, ucrit => cdmin + + implicit none + + real(kind=kind_phys), parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 + real(kind=kind_phys), parameter :: dked_min =0.01, dked_max=250.0 + + real(kind=kind_phys), parameter :: gptwo=2.0 + + real(kind=kind_phys) , parameter :: bnfix = 6.28/300., bnfix2= bnfix * bnfix + real(kind=kind_phys) , parameter :: bnfix4 = bnfix2 * bnfix2 + real(kind=kind_phys) , parameter :: bnfix3 = bnfix2 * bnfix +! +! make parameter list that will be passed to SOLVER +! + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + + real(kind=kind_phys) , parameter :: zcimin = 2.5 + real(kind=kind_phys) , parameter :: zcimax = 125.0 + real(kind=kind_phys) , parameter :: zgam = 0.25 +! +! Verical spectra +! + real(kind=kind_phys) , parameter :: pind_wd = 5./3. + real(kind=kind_phys) , parameter :: sind_kz = 1. + real(kind=kind_phys) , parameter :: tind_kz = 3. + real(kind=kind_phys) , parameter :: stind_kz = sind_kz + tind_kz +! +! copies from kmob_ugwp namelist +! + real(kind=kind_phys) :: nslope ! the GW sprctral slope at small-m + real(kind=kind_phys) :: lzstar + real(kind=kind_phys) :: lzmin + real(kind=kind_phys) :: lzmax + real(kind=kind_phys) :: lhmet + real(kind=kind_phys) :: tamp_mpa !amplitude for GEOS-5/MERRA-2 + real(kind=kind_phys) :: tau_min ! min of GW MF 0.25 mPa + integer :: ilaunch + real(kind=kind_phys) :: gw_eff + + real(kind=kind_phys) :: v_kxw, rv_kxw, v_kxw2 + + + +!=========================================================================== + integer :: nwav, nazd, nst + real(kind=kind_phys) :: eff + + real(kind=kind_phys) :: zaz_fct, zms + real(kind=kind_phys), allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real(kind=kind_phys), allocatable :: zcosang(:), zsinang(:) + real(kind=kind_phys), allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) + +! +! GW-eddy constants for wave-mode dissipation by background and stability of +! "final" flow after application of GW-effects +! + real(kind=kind_phys), parameter :: iPr_pt = 0.5 + real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. + real(kind=kind_phys), parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable + real(kind=kind_phys), parameter :: ric =0.25 + real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 + real(kind=kind_phys), parameter :: prmax = 4.0 +! + contains +!============================================================================ + subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw, version) + +! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & +! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw,version) +! + implicit none +! +!input-control for solvers: +! nwaves, nazdir, nstoch, effac, do_physb, kxw +! +! + integer, intent(in) :: me, master, nwaves, nazdir, nstoch + integer, intent(in) :: version + + real(kind=kind_phys), intent(in) :: effac, kxw + logical, intent(in) :: do_physb + +! +!locals +! + real(kind=kind_phys) :: dlzmet + real(kind=kind_phys) :: cstar,rcstar, nslope3, fnorm, zcin + + integer :: inc, jk, jl, iazi +! + real(kind=kind_phys) :: zang, zang1, znorm + real(kind=kind_phys) :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + real(kind=kind_phys) :: fpc, fpc_dc + real(kind=kind_phys) :: ae1,ae2 + if( nwaves == 0) then +! +! redefine from the deafault +! + nwav = incdim + nazd = iazidim + nst = 0 + eff = 1.0 + gw_eff = eff + else +! +! from input.nml +! + nwav = nwaves + nazd = nazdir + nst = nstoch + gw_eff = effac + endif + + + v_kxw = kxw ; v_kxw2 = v_kxw*v_kxw + rv_kxw = 1./v_kxw + + allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) + allocate ( zcosang(nazd), zsinang(nazd) ) + allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) + +! if (me == master) then +! print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' +! +! print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch +! print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. +! print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 +! endif + + zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. + +! +! set up azimuth directions and some trig factors +! +! + zang = pi2 / float(nazd) + +! get normalization factor to ensure that the same amount of momentum +! flux is directed (n,s,e,w) no mater how many azimuths are selected. +! + znorm = 0.0 + do iazi=1, nazd + zang1 = (iazi-1)*zang + zcosang(iazi) = cos(zang1) + zsinang(iazi) = sin(zang1) + znorm = znorm + abs(zcosang(iazi)) + enddo +! zaz_fct = 1.0 + zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums + +! define coordinate transform for "Ch" ....x = 1/c stretching transform +! ----------------------------------------------- +! +! x=1/Cphase transform +! Scinocca 2003. x = 1/c stretching transform +! + zxmax = 1.0 / zcimin + zxmin = 1.0 / zcimax + zxran = zxmax - zxmin + zdx = zxran / real(nwav-1) ! dkz +! + ae1=zxran/zgam + zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. + zx2 = zxmin - zx1 + +! +! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform +! it represents additional "empirical" redistribution of "spectral" mode in C-space +! + zms = pi2 / lzstar + + do inc=1, nwav + ztx = real(inc-1)*zdx+zxmin + ae1 = (ztx-zxmin)/zgam + zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 + zci(inc) = 1.0 /zx ! + zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + enddo +! +! +! alternatuve lzmax-lzmin without x=1/c transform +! +! + if (version == 1) then + + dlzmet = (lzmax-lzmin)/ real(nwav-1) + do inc=1, nwav + lzmet(inc) = lzmin + (inc-1)*dlzmet + mkzmet(inc) = pi2/lzmet(inc) + zci(inc) =lzmet(inc)/(pi2/bnfix) + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + + enddo + + zdx = (zci(nwav)-zci(1))/ real(nwav-1) + do inc=1, nwav + zdci(inc) = zdx + enddo + + cstar = bnfix/zms + rcstar = 1./cstar + ENDIF ! if (version == 1) then + + RETURN +!=================== Diag prints after return ==================== + if (me == master) then + print * + print *, 'ugwp_v0: zcimin=' , zcimin + print *, 'ugwp_v0: zcimax=' , zcimax + print *, 'ugwp_v0: zgam= ', zgam + print * + +! print *, ' ugwp_v1 nslope=', nslope + print * + print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) + print *, 'ugwp_v1: zcimax/zci=' , minval(zci) + print *, 'ugwp_v1: cd_crit=', ucrit + print *, 'ugwp_v1: launch_level', ilaunch + print *, ' ugwp_v1 lzstar=', lzstar + print *, ' ugwp_v1 nslope=', nslope + + print * + nslope3=nslope+3.0 + do inc=1, nwav + zcin =zci(inc)*rcstar + fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) + fpc_dc = fpc * zdci(inc) + write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) + enddo + endif + + + + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) + + end subroutine initsolv_wmsdis +! +! + end module ugwp_wmsdis_init diff --git a/physics/cires_ugwpv1_module.F90 b/physics/cires_ugwpv1_module.F90 new file mode 100644 index 000000000..13b7752a5 --- /dev/null +++ b/physics/cires_ugwpv1_module.F90 @@ -0,0 +1,529 @@ + +module cires_ugwpv1_module + +! +! driver is called after pbl & before chem-parameterizations +! it uses ugwp_common (like phys_cons) and some module-param od solvers/sources init-modules +!.................................................................................... +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +!................................................................................... +! +! + use machine, only : kind_phys + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + + implicit none + logical :: module_is_initialized + + character(len=8) :: strsolver='pss-1986' + logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources + logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver + integer, parameter :: idebug_gwrms=0 ! control for diag computaions pw wind-temp GW-rms and MF fluxs + logical, parameter :: do_adjoro = .false. + + real(kind=kind_phys), parameter :: max_kdis = 450. ! 400 m2/s + real(kind=kind_phys), parameter :: max_axyz = 450.e-5 ! 400 m/s/day + real(kind=kind_phys), parameter :: max_eps = max_kdis*4.e-4 ! max_kdis*BN2 + real(kind=kind_phys), parameter :: maxdudt = max_axyz + real(kind=kind_phys), parameter :: maxdtdt = max_eps*1.e-3 ! max_kdis*BN2/cp + real(kind=kind_phys), parameter :: dked_min = 0.01 + real(kind=kind_phys), parameter :: dked_max = max_kdis +! +! +! Pr = Kv/Kt < 1 for upper layers; Pr_mol = 1./1.95 check it +! + real(kind=kind_phys), parameter :: Pr_kvkt = 1./1. ! kv/kt = 1./3. + real(kind=kind_phys), parameter :: Pr_kdis = Pr_kvkt/(1.+Pr_kvkt) + + real(kind=kind_phys), parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw + real(kind=kind_phys), parameter :: iPr_turb =1./3., iPr_mol =1.95 + + real(kind=kind_phys), parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model + real(kind=kind_phys), parameter :: linsat = 1.00 + real(kind=kind_phys), parameter :: linsat2 = linsat*linsat + + real(kind=kind_phys), parameter :: ricrit = 0.25 + real(kind=kind_phys), parameter :: frcrit = 0.50 + + + integer :: knob_ugwp_version = 1 + integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) + integer, dimension(4) :: knob_ugwp_source=(/1,0,1,0/) ! [1,0,1,1] - (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_wvspec=(/1,32,32,32/) ! number of waves for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_azdir=(/2,4,4,4/) ! number of wave azimuths for-(oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_stoch=(/0,0,0,0/) ! 0 - deterministic ; 1 - stochastic + real(kind=kind_phys), dimension(4) :: knob_ugwp_effac=(/1.,1.,1.,1./) ! efficiency factors for- (oro, fronts, conv, imbf-owp] + + integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag + integer :: knob_ugwp_doheat=1 ! 1 -gwheat + integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing + integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw + integer :: knob_ugwp_nslope = 1 ! spectral"growth" S-slope of GW-energy spectra mkz^S + + real(kind=kind_phys) :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs + real(kind=kind_phys) :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km + real(kind=kind_phys) :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_taumin = 0.25e-3 + real(kind=kind_phys) :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) + real(kind=kind_phys) :: knob_ugwp_lhmet = 200.e3 ! 200 km + + logical :: knob_ugwp_tlimb = .true. + character(len=8) :: knob_ugwp_orosolv='pss-1986' + + real(kind=kind_phys) :: kxw = 6.28/200.e3 ! single horizontal wavenumber of ugwp schemes +! + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + + real(kind=kind_phys) :: ugwp_effac +! + integer :: launch_level = 55 +! + namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & + knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & + knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & + knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & + knob_ugwp_tlimb, knob_ugwp_orosolv + +! +! allocatable arrays, initilized during "cires_ugwp_init" & +! released during "cires_ugwp_finalize" +! + real(kind=kind_phys), allocatable :: kvg(:), ktg(:), krad(:), kion(:) + real(kind=kind_phys), allocatable :: zkm(:), pmb(:) + real(kind=kind_phys), allocatable :: rfdis(:), rfdist(:) +! +! RF-not active now +! + integer :: levs_rf + real(kind=kind_phys) :: pa_rf, tau_rf +! +! simple modulation of tau_ngw by the total rain/precip strength +! + real(kind=kind_phys), parameter :: rain_max=8.e-5, rain_lat=41.0, rain_lim=1.e-5 + real(kind=kind_phys), parameter :: w_merra = 1.0, w_nomerra = 1.-w_merra, w_rain =1. + real(kind=kind_phys), parameter :: mtau_rain = 1.e-3, ft_min =0.5, ft_max=2 + real(kind=kind_phys), parameter :: tau_ngw_max = 20.e-3 ! 20 mPa + real(kind=kind_phys), parameter :: tau_ngw_min = .20e-3 ! .2 mPa +! +! Bushell et al. (2015) tau = tau_rainum (~3.8 km) x sqrt(Precip/base_rainum) +! + real(kind=kind_phys), parameter :: tau_rainum = 0.7488e-3 ! 0.74 mPa + real(kind=kind_phys), parameter :: base_rainum = 0.1e-5 ! ~0.1 mm/day + real(kind=kind_phys), parameter :: pbase_um =1./sqrt(base_rainum) * tau_rainum ! + integer, parameter :: metoum_rain = 0 +!================================================================= +! switches that can ba activated for NGW physics include/omit +! +! rotational, non-hydrostatic and eddy-dissipative +! F_coriol F_nonhyd F_kds +!=================================================== + real(kind=kind_phys), parameter :: F_coriol=1.0 ! Coriolis effects + real(kind=kind_phys), parameter :: F_nonhyd=1.0 ! Nonhydrostatic waves + real(kind=kind_phys), parameter :: F_kds =0.0 ! Eddy mixing due to GW-unstable below + + + contains +! +!----------------------------------------------------------------------- +! +! init of cires_ugwp (_init) called from CCPP cap file +! +! --------------------------------------------------------------------------------- +! non-ccpp .... +! +! subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & +! lonr, latr, levs, ak, bk, pref, dtp) +!----------------------------------------------------------------------------------- + + subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, & + errmsg, errflg) +! +! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 +! + use netcdf + use ugwp_oro_init, only : init_oro_gws + use ugwp_conv_init, only : init_conv_gws + use ugwp_fjet_init, only : init_fjet_gws + use ugwp_okw_init, only : init_okw_gws + use ugwp_lsatdis_init, only : initsolv_lsatdis + + use ugwp_wmsdis_init, only : initsolv_wmsdis + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + integer, intent (in) :: logunit + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + integer, intent (in) :: jdat_gfs(8) + real(kind=kind_phys), intent (in) :: ak(levs+1), bk(levs+1), pref + real(kind=kind_phys), intent (in) :: dtp +! +! consider to retire them +! + real(kind=kind_phys), intent (in) :: con_pi, con_rerth + + character(len=64), intent (in) :: fn_nml2 + character(len=64), parameter :: fn_nml='input.nml' + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! character, intent (in) :: input_nml_file +! + integer :: ios + logical :: exists + + integer :: ncid, iernc, vid, dimid, status + integer :: k + integer :: ddd_ugwp, curday_ugwp +! integer :: version + + +! + if (me == master) print *, trim (fn_nml), ' GW-namelist file ' + inquire (file =trim (fn_nml) , exist = exists) +! + if (.not. exists) then + if (me == master) & + write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' + + else + open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = cires_ugwp_nml) + close (nlunit) +! + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + strsolver= knob_ugwp_orosolv + + curday_ugwp = jdat_gfs(1)*10000 + jdat_gfs(2)*100 +jdat_gfs(3) + call calendar_ugwp(jdat_gfs(1), jdat_gfs(2), jdat_gfs(3), ddd_ugwp) + +! write version number and namelist to log file + if (me == master) then + write (logunit, *) " ================================================================== " + write (logunit, *) "CCPP cires_ugwp_namelist_extended_v1" + write (logunit, nml = cires_ugwp_nml) + write (logunit, *) " ================================================================== " + + write (6, *) " ================================================================== " + write (6, *) "CCPP cires_ugwp_namelist_extended_v1" + write (6, nml = cires_ugwp_nml) + write (6, *) " ================================================================== " + write (6, *) "calendar_ugwp ddd_ugwp=", ddd_ugwp + write (6, *) "calendar_ugwp curday_ugwp=", curday_ugwp + write (6, *) " ================================================================== " + write (6, *) ddd_ugwp, ' jdat_gfs ddd of year ' + endif +! +! effective kxw - resolution-aware +! +! + kxw = pi2/knob_ugwp_lhmet +! +! +! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff +! +! +! allocate(fcor(latr), fcor2(latr) ) +! + allocate( kvg(levs+1), ktg(levs+1) ) + allocate( krad(levs+1), kion(levs+1) ) + allocate( zkm(levs), pmb(levs) ) + +! +! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 +! + + do k=1, levs + pmb(k) = ak(k) + pref*bk(k) ! Pa -unit Pref = 1.e5, pmb = Pa + zkm(k) = -hpskm*alog(pmb(k)/pref) + enddo + +! +! find ilaunch +! + + do k=levs, 1, -1 + if (pmb(k) .gt. knob_ugwp_palaunch ) exit + enddo + + launch_level = max(k-1, 5) ! above 5-layers from the surface + if (me == master) then + print *, 'cires_ugwpv1 klev_ngw =', launch_level, nint(pmb(launch_level)) + endif +! +! Part-1 :init_global_gwdis again "damn"-con_p +! + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) + +! +! Part-2 :init_SOURCES_gws +! + +! +! call init-solver for "stationary" multi-wave spectra and sub-grid oro +! + call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw ) +! +! call init-sources for "non-sationary" multi-wave spectra +! + do_physb_gwsrcs=.true. + + IF (do_physb_gwsrcs) THEN + +! if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' + if (knob_ugwp_wvspec(4) > 0) then +! okw + call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & + knob_ugwp_stoch(4), knob_ugwp_effac(4), & + 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 : con_pi, con_rerth, + call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), & + lonr, kxw ) +! if (me == master) & +! print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + + endif + + ENDIF !IF (do_physb_gwsrcs) + +!====================== +! Part-3 :init_SOLVERS +! ===================== +! +! call init-solvers for "broad" non-stationary multi-wave spectra +! + if (knob_ugwp_solver==1) then +! + kxw = pi2/lhmet + call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) + endif + if (knob_ugwp_solver == 2) then +! +! re-assign from namelists +! + nslope = knob_ugwp_nslope ! the GW sprctral slope at small-m + lzstar = knob_ugwp_lzstar + lzmax = knob_ugwp_lzmax + lzmin = knob_ugwp_lzmin + lhmet = knob_ugwp_lhmet + tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 + tau_min =knob_ugwp_taumin ! min of GW MF 0.25 mPa + ilaunch = launch_level + + kxw = pi2/lhmet + + call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw, knob_ugwp_version) + + endif + + +!====================== + module_is_initialized = .true. + if (me == master) print *, ' CIRES_ugwpV1 is initialized ', module_is_initialized + + end subroutine cires_ugwpv1_init + + +!============================================= + + subroutine cires_ugwp_advance +!----------------------------------------------------------------------- +! FV3-dycore and CCPP-physics has limited options to +! add "horizontal" gradients of winds and temp-re to +! compute GW-triggers: reserved option if it will be funded ...... +! +! the day-to-day variable sources/spectra and diagnostics for stochastic "triggers" +! +! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields +! and use for stochastic GWP-sources "memory" +! +! this option is not active due to "weak" flexibility +! in communication between "ccpp/gfsphysics" and FV3-dycore +! extension of State%in is needed to pass horizontal gradients +! winds and temperature to compute "spontatneous" GW triggers +!----------------------------------------------------------------------- + implicit none +! +! update GW sources and dissipation +! a) physics-based GW triggers eliminated from cires_ugwpv1_triggers.F90 +! b) stochastic-based spectra and amplitudes is not considered +! c) use "memory" on GW-spectra from previous time-step is not considered +! d) update "background" dissipation of GWs as needed (option for FV3WAM) +! + end subroutine cires_ugwp_advance + +! +! ----------------------------------------------------------------------- +! finalize of cires_ugwp_dealloc +! ----------------------------------------------------------------------- + + + subroutine cires_ugwp_dealloc +! +! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" +! before "end" of the FV3GFS +! + implicit none +! +! deallocate arrays employed in: +! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! + if (allocated (kvg)) deallocate (kvg) + if (allocated (ktg)) deallocate (ktg) + if (allocated (krad)) deallocate (krad) + if (allocated (kion)) deallocate (kion) + if (allocated (zkm)) deallocate (zkm) + if (allocated (pmb)) deallocate (pmb) +! if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) +! if (allocated (tau_limb)) deallocate (tau_limb) +! if (allocated (days_limb)) deallocate(days_limb) + + + end subroutine cires_ugwp_dealloc + +! +! + subroutine calendar_ugwp(yr, mm, dd, ddd_ugwp) +! +! computes day of year to get tau_limb forcing written with 1-day precision +! + implicit none + integer, intent(in) :: yr, mm, dd + integer :: ddd_ugwp + + integer :: iw3jdn + integer :: jd1, jddd + jd1 = iw3jdn(yr,1,1) + jddd = iw3jdn(yr,mm,dd) + ddd_ugwp = jddd-jd1+1 + + end subroutine calendar_ugwp + + + subroutine ngwflux_update(me, master, im, levs, kdt, ddd, curdate, & + tau_ddd, xlatd, sinlat,coslat, rain, tau_ngw) + + use machine, only: kind_phys + implicit none +!input + + integer, intent(in) :: me, master !, jdat(8) + integer, intent(in) :: im, levs, kdt + integer, intent(in) :: ddd, curdate + +! integer, intent(in), dimension(im) :: j1_tau, j2_tau +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j2tau, ddy_j1tau + + real(kind=kind_phys), intent(in), dimension(im) :: xlatd, sinlat,coslat + real(kind=kind_phys), intent(in), dimension(im) :: rain, tau_ddd + + real(kind=kind_phys), intent(inout), dimension(im) :: tau_ngw +! +! locals +! + + integer :: i, j1, j2, k, it1, it2, iday + real(kind=kind_phys) :: tem, tx1, tx2, w1, w2, wlat, rw1, rw2 + real(kind=kind_phys) :: tau_rain, flat_rain, tau_3dt + +! + +! code below inside cires_tauamf_data.F90 +! it1 = 2 +! do iday=1, ntau_d2t +! if (float(ddd) .lt. days_limb(iday) ) then +! it2 = iday +! exit +! endif +! enddo +! it2 = min(it2,ntau_d2t) +! it1 = max(it2-1,1) +! if (it2 > ntau_d2t ) then +! print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t +! stop +! endif +! w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) +! w1 = 1.0-w2 +! do i=1, im +! j1 = j1_tau(i) +! j2 = j2_tau(i) +! tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) +! tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) +! tau_ddd(i) = tx1*w1 + w2*tx2 +! +! add modulattion by the total "rain"-strength Yudin et al.(2020-FV3GFS) and Bushell et al. (2015-UM/METO) +! + do i=1, im + tau_3dt = tau_ngw(i) * w_merra + w_nomerra *tau_ddd(i) + + if (w_rain > 0. .and. rain(i) > 0.) then + + wlat = abs(xlatd(i)) + + if (wlat <= rain_lat .and. rain(i) > rain_lim) then + flat_rain = wlat/rain_lat + rw1 = 0.75 * flat_rain ; rw2 = 1.-rw1 + + tau_rain = tau_3dt * rw1 + rw2 * mtau_rain*min(rain_max, rain(i))/rain_lim + tau_rain = tau_3dt*(1.-w_rain) + w_rain* tau_rain +! +! restict variations from the "tau_ngw" without precip-impact +! +! real, parameter :: ft_min =0.5*tau_g5 < tau_rain < ft_max =2. *tau_g5 +! + if (tau_rain < ft_min *tau_3dt) tau_rain = ft_min *tau_3dt + if (tau_rain > ft_max *tau_3dt) tau_rain = ft_max *tau_3dt + + tau_3dt = tau_rain + + endif + if (metoum_rain == 1) then + tau_rain = min( sqrt(rain(i))*pbase_um, tau_ngw_max) + tau_3dt = max(tau_ngw_min, tau_rain) + endif + endif + tau_ngw(i) = tau_3dt + enddo + + end subroutine ngwflux_update +! + end module cires_ugwpv1_module + diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 new file mode 100644 index 000000000..46191f404 --- /dev/null +++ b/physics/cires_ugwpv1_oro.F90 @@ -0,0 +1,1104 @@ +module cires_ugwpv1_oro + +contains + + subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & + xlatd, sinlat, coslat, sparea, & + cdmbgwd, hprime, oc, oa4, clx4, theta, sigmad, & + gammad, elvmaxd, sgh30, kpbl, & + u1 ,v1, t1, q1, prsi,del,prsl,prslk, zmeti, zmet, & + pdvdt, pdudt, pdtdt, pkdis, dusfc, dvsfc,rdxzb , & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) + +!--------------------------------------------------------------------------- +! ugwp_v1: orogw_v1 following recent updates of Lott & Miller 1997 +! eventually will be replaced with more "advanced" LLWB +! and multi-wave solver that produce competitive FV3GFS-skills +! +! computation of kref for ogw + coorde diagnostics +! all constants/parameters inside cires_ugwp_initialize.f90 +! +! 10/2020 main updates +! (a) introduce extra diagnostics of x-y obl-ofd-ogw as in the GSL-drag +! for intercomparisons +! +! (b) quit with cdmbgwd(1:2) +! cdmbgwd(1) = 1 for all resolutions, number of hills control SA-effects +! cdmbgwd(2) = 1 ...............number of hills control SA-effects +! +! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) +! alternative lheff = min( dogw=hprime/sigma*gamma, dx) +! we still not use the "broad spectral solver" +! +! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW +! +! (e) for linsat-solver the total "eddy" damping Ked = Ked * Nhills, +! scale-aware amplification of the momentum deposition for low-res runs +!---------------------------------------- + + use machine , only : kind_phys + use ugwp_common, only : dw2min, velmin, grav, omega1, rd, cpd, rv, pi, arad, fv + use ugwp_common, only : rcpdt, grav2, rgrav, rcpd, rcpd2 + use ugwp_common, only : rad_to_deg, deg_to_rad, pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min + + use ugwp_oro_init, only : rimin, ric, efmin, efmax, & + hpmax, hpmin, sigfaci => sigfac, & + dpmin, minwnd, hminmt, hncrit, & + rlolev, gmax, veleps, factop, & + frc, ce, ceofrc, frmax, cg, & + fdir, mdir, nwdir, & + cdmb, cleff, fcrit_v1, & + n_tofd, ze_tofd, ztop_tofd + + use cires_ugwpv1_module, only : kxw, max_kdis, max_axyz + +!---------------------------------------- + implicit none +!---------------------------------------- +! internal parameters +!---------------------------------------- + real(kind=kind_phys), parameter :: sigfac = 3 ! N*hprime height of Subgrid Hill over which SSO-flo + real(kind=kind_phys), parameter :: sigfacs = 0.25 ! M*hprime height is the low boundary of the hill + + real(kind=kind_phys), parameter :: dbmax = 1./3600./12. ! max-Krmtb in hours for u=10 m/s => 20 m/s/day + character(len=8) :: strsolver='pss-1986' ! current operational Ri-solver or 'spect_2020' + + + real(kind=kind_phys) :: gammin = 0.00999999 ! a/b = gammma_min =1% <====> + real(kind=kind_phys), parameter :: nhilmax = 15. ! max number of SSO-hills in grid-box + real(kind=kind_phys), parameter :: sso_min = 3000. ! min-lenghth of the hill, GTOP30 ~dx~1 km + + real(kind=kind_phys), parameter :: nfr = 2.+1. ! power in the emprical Function(Fr/Frc) + real(kind=kind_phys), parameter :: afr = 1. ! (Fr/Frc)^2/(afr +[Fr/Frc]^nfr), Fr = h*mkz + real(kind=kind_phys), parameter :: frnorm =afr+1.0 ! to get cont-ous taulin(Fr=Frc) = tau_nonlin(Fr=Frc) ! + real(kind=kind_phys), parameter :: max_frf =2.0 ! max-value of non-lin flux over the linear at Fr=Frc + + logical, parameter :: do_adjoro = .false. ! +!---------------------------------------- + + integer, intent(in) :: im, km, imx, kdt + integer, intent(in) :: me, master + logical, intent(in) :: do_tofd + + integer, intent(in) :: kpbl(im) ! index for the pbl top layer! + real(kind=kind_phys), intent(in) :: dtp ! time step + real(kind=kind_phys), intent(in) :: cdmbgwd(2) + + real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & + clx4(im,4), theta(im), & + sigmad(im), gammad(im), elvmaxd(im) +! + real(kind=kind_phys), intent(in) :: sgh30(im) + + real(kind=kind_phys), intent(in), dimension(im,km) :: & + u1, v1, t1, q1,del, prsl, prslk, zmet + + real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti + + real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) + real(kind=kind_phys), intent(in) :: sparea(im) + +! +!output -phys-tend +! + real(kind=kind_phys),dimension(im,km),intent(out) :: & + pdvdt, pdudt, pkdis, pdtdt +! output - diag-coorde + real(kind=kind_phys),dimension(im,km),intent(out) :: & + dudt_ogw,dvdt_ogw, dudt_obl,dvdt_obl, dudt_ofd,dvdt_ofd + + real(kind=kind_phys),dimension(im),intent(out) :: dusfc, dvsfc, & + du_ogwcol,dv_ogwcol, du_oblcol,dv_oblcol, du_ofdcol,dv_ofdcol +! + real(kind=kind_phys),dimension(im),intent(out) :: rdxzb + real(kind=kind_phys),dimension(im),intent(out) :: zobl, zogw, zlwb, tau_ogw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! +! locals vars for SSO +! + + real(kind=kind_phys), dimension(im) :: oa, clx + real(kind=kind_phys), dimension(im) :: sigma, gamma, elvmax ! corrected sigmaD, gammaD, elvmaxD + + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax + + real(kind=kind_phys) :: arhills(im), mkd05_hills(im) ! number of hills in the grid + real(kind=kind_phys) :: taub_kd05(im) +! +! locals mean flow ...etc +! + real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro + real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco +!================== +!mtb +!================== + real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk + real(kind=kind_phys), dimension(im) :: wk, pe, ek, up + + real(kind=kind_phys), dimension(im,km) :: db, ang, uds + + real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr + real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 + real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem + +!================== +! tofd +! some constants now in "use ugwp_oro_init" + "use ugwp_common" +! +!================== + + real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf + real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 + real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 + real(kind=kind_phys), dimension(km) :: up1, vp1, zpm +!================== +! ogw +!================== + real(kind=kind_phys) :: xlingfs + logical :: icrilv(im) +! + real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & + roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 +! + real(kind=kind_phys) :: taup(im,km+1), taud(im,km) + real(kind=kind_phys) :: taub(im), taulin(im), tausat(im), ahdxres(im) + real(kind=kind_phys) :: heff, hsat, hdis + + integer, dimension(im) :: kref, idxzb, ipt, khtop, iwk, izlow +! +! local real scalars +! + real(kind=kind_phys) :: bnv, fr, ri_gw, brvf, fr2 + real(kind=kind_phys) :: tem, tem1, tem2, temc, temv + real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 + real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv + real(kind=kind_phys) :: scork, rscor, hd, fro, sira + real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk + + real(kind=kind_phys) :: windik, wdir + real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge + + real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 + real(kind=kind_phys) :: belps, aelps, nhills, selps + +! real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad +! real(kind=kind_phys) :: pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min + + real(kind=kind_phys) :: cleff_max ! resolution-aware max-wn + real(kind=kind_phys) :: nonh_fact ! non-hydroststic factor 1.-(kx/kz_hh)**2 + real(kind=kind_phys) :: fcrit2 + real(kind=kind_phys) :: fr_func, frnd +! +! +! local integers +! + integer :: kmm1, kmm2, lcap, lcapp1 + integer :: npt, kbps + integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll + integer :: k_mtb, k_zlow, ktrial, klevm1 + integer :: i, j, k +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!=========================== +! First step Check do we have sub-grid hills +! +! +! out-arrays are zreoed in unified_ugwp.F90 +! + do i=1,im + rdxzb(i) = 0.0 + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + ipt(i) = 0 + enddo + +! ---- for lm and gwd calculation points +!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 +!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) +!---- for lm and gwd calculation points +! ccpp-gwdps.f PARAMETER (hpmax=2400.0, hpmin=1.0) parameter (elvmax > hminmt=50.) + + npt = 0 + do i = 1,im + if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then + npt = npt + 1 + ipt(npt) = i + endif + enddo + + if (npt == 0) then +! print *, 'orogw_v1 npt = 0 elvmax ', maxval(elvmaxd), hminmt +! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin + return ! no ogw/mbl calculation done + endif + + +!================================= +! Start if npt >= 1 +! initialize gamma and sigma for +! performing the QC of SSO inputs +!================================= + gamma(:) = gammad(:) + sigma(:) = sigmad(:) +! +!======================================================================= +! mtb-blocking sigma_min and dxres => cires_initialize (best way ....) +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + +! ! GTOP30-arc dx~1Km res-n so sso_hill ~ (2-4)*dx + cleff_max = pi2/max(dsmin/5.,sso_min) ! maxval for kx = 6.28/(dx_min/5. ~2.5 km) for C768 + cleff_max = pi2/dsmin + + hdxres = 0.5*dsmax + + gammin = min(sso_min/hdxres, 1.) + gammin = max(0.1, gammin) + ! sigma-degined as tan(angle) = h/2: L/2= h/L + sigmin = hpmin/hdxres ! min-slope Hmin= 2*hpmin, dxres=Lmax + +! if ( kdt == 1 .and. me == master) then +! print *, ' orogw_v1 scale2 ', cdmbgwd(2) +! print *, ' orogw_v1 imx ', imx +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 sso_min ', sso_min +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 npt number of GRID-cells with hills ', npt +! endif + +!============================================================ +! Purpose to adjust oro-specification on the fly +! needs to be done 1-time during init-n for each block +! hprime sigma gamma and grid-length must be "related" +! width_mount_a = hprime/sigma < dxres cannot access dxres +! width_mount_b = width_mount_a * gamma +! +! Sellipse= pi * a*b = (width_mount_a)^2 *gamma <= Sarea +! Limiters on "elongated" hills gamma= a/b < gam_min +! Limiters on "longest" hills (b, a) <= sqrt(area) +! +! 0.01=gammin < gamma=a_hill/b_hill < 1 +! hpmin/(dx/2)=sigmin < sigma= hprime/a_ell < 1. +! Nhills = (dx*dy=Sarea)/(pi* a_hill *b_hill) +!============================================================= + + arhills(:) =0. + mkd05_hills(:) =0. + + do j = 1,npt + i = ipt(j) + dxres = sqrt(sparea(i)) + ahdxres(j) = dxres + if (gamma(i) > 1.0) gamma(i) = 1.0 + + gamma(i) = max(gammin, gamma(i)) +! +! min-adjustment: 1) abs(gamma(i)) ; 2) sigres = max(sigmin, sigma(i)) +! + sigres = max(sigmin, sigma(i)) + sigma(i) =sigres + aelps = min( hprime(i)/sigres, dxres) + belps = min(aelps/abs(gamma(i)), dxres) + gamma(i) = aelps/belps + + if (do_adjoro ) then +! +! more adjustments "lengths", gamma and sigma, assuminng H_hill=2*hprime +! + if (hprime(i) > hdxres*sigres) sigres= hprime(i)/dxres + aelps = min( hprime(i)/sigres, hdxres) + sigma(i) = sigres + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i), dxres) +! +! small-scale "turbulent" oro-hills < sso_min, sso_min_dx = 3km +! will be treated as "circular" elevations +! + if( aelps < sso_min ) then +! +! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm +! + aelps = sso_min + if (belps < sso_min ) then + gamma(i) = 1.0 + belps = aelps*gamma(i) + else + gamma(i) = min(aelps/belps, 1.0) + endif + + sigma(i) = hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + + endif !aelps < sso_min + endif ! if (do_adjoro ) + + selps = belps*belps*gamma(i)*pi ! area of the elliptical hill + nhills = min(nhilmax, sparea(i)/selps) + arhills(j) = max(nhills, 1.0) + +! if (kdt==1 ) write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, belps*1.e-3, sigma(i),gamma(i) +! 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) + + enddo + +!======================================================================= +! mtb-blocking : LM-1997; Zadra et al. 2004 ;metoffice dec 2010 H Wells +!======================================================================= + + do i=1,npt + khtop(i) = 2 + idxzb(i) = 0 + izlow(i) = 1 + enddo + + do k=1,km + do i=1,im + db(i,k) = 0.0 + ang(i,k) = 0.0 + uds(i,k) = 0.0 + enddo + enddo + + kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 + lcap = km ; lcapp1 = lcap + 1 + cdmb4 = 0.25*cdmb + + do i = 1, npt + j = ipt(i) + elvmax(j) = min( sigfac * hprime(j), hncrit) +! +!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) +! SSO-effects from the surface to "ELVMAX" =4*hprime + ELVMAX + enddo + + +!=================================================================== +! below khtop-level H= 3*hp, and izlow = 0.5*Hp or the "first" layer +! are used tp estimate "Mean" Flow that interact with SG-HILL +! if sig*HP < Hpbl => GWs-> above PBL +! WRF: ( 1 to max(2*Hp or H_pbl) +! GFS-15/16: OGWs (1 to max(Kpbl+1, or K_dPs=(Ps-Pk=50hPa) ~ 950 mb) +! excitation above Kref +! BLOCKING: ZDOMAIN (1 - Kaver => ELVMAX(J) + sigfac * hp) +!=================================================================== + + + do k = 1, kmm1 + do i = 1, npt + j = ipt(i) + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) +! +! GFSv15/16: izlow=1 +! elvmax(j)=elvmaxd(J) + sig*hp: if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) khtop(i) = max(khtop(i), k+1 ) +! + + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(i), k+1 ) + if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) + enddo + enddo +! + do k = 1,km + do i =1,npt + j = ipt(i) + vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) + vtk(i,k) = vtj(i,k) / prslk(j,k) + ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid + taup(i,k) = 0.0 + enddo + enddo +! +! perform ri_n or ri_mf computation for both OGW and OBL +!23456 + do k = 1,kmm1 + do i =1,npt + j = ipt(i) + rdz = 1. / (zmet(j,k+1) - zmet(j,k)) + tem1 = u1(j,k) - u1(j,k+1) + tem2 = v1(j,k) - v1(j,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! having ri_n +! we may place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme +! + enddo + enddo + k = 1 +!23456 + do i = 1, npt + bnv2(i,k) = bnv2(i,k+1) + enddo +! +! level khtop => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) +!23456 + do i = 1, npt + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == khtop(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + pe (i) = 0.0 + ek (i) = 0.0 + bnv2bar(i) = 0.0 +! +! computation of the mean flow char zlow < z < ztop =sigfac*hprime +!23456 + do k = k_zlow, khtop(i)-1 + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo + enddo +!23456 + do i = 1, npt + j = ipt(i) +! +! integrate from ztoph = sigfac*hprime down to zblk if exists +! find ph_blk, dz_blk as introduced in LM-97 and ifs +!23456 + ph_blk =0. + do k = khtop(i), 1, -1 + phiang = atan2(v1(j,k),u1(j,k)) + phiang = theta(j)*rad_to_deg - phiang + if ( phiang > pih ) phiang = phiang - pi + if ( phiang < -pih ) phiang = phiang + pi + ang(i,k) = phiang + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +!23456 + if (idxzb(i) == 0 ) then + dz_blk = zmeti(j,k+1) - zmeti(j,k) + pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk + up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) + ek(i) = 0.5 * up(i) * up(i) + ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) + +! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs +! if ( pe(i) >= ek(i) ) then +! --- LM97/IFS + if(ph_blk >= fcrit_v1 ) then + idxzb(i) = k + zobl (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif +!23456 + endif + enddo +! +! --- the drag for the blocked flow +! + if ( idxzb(i) > 0 ) then +! +! (4.16)-ifs description +! + gam2 = gamma(j)*gamma(j) + bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 + cgam = 0.48*gamma(j) + 0.30*gam2 + do k = idxzb(i)-1, 1, -1 +!23456 +! empirical height dep-nt "blocking" length from LM-1997/IFS +! + zlen = sqrt( (zobl(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 + rdem = cosang2 + gam2 * sinang2 + rnom = cosang2*gam2 + sinang2 +! +! metoffice dec 2010 +! correction of H. Wells & A. Zadra for the +! aspect ratio of the elliptical hill seen by mean flow +! + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + sigres = max(sigmin, sigma(j)) + mtbridge = zr * sigres*zlen / hprime(j) +! dbtmp = cdmb4*mtbridge*max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) ! (4.15)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam * sinang2) ! (4.16)-ifs +! +! linear damping due to OBL [1/sec]=[U/L_block_orthogonal] +! more accurate along 2-axes of ellipse, here zr-factor is based on Phillips' analytics +! + db(i,k)= dbtmp * uds(i,k) +! if (db(i,k) > dbmax) print *, ' db > dbmax ', 1./db(i,k)/3600., uds(i,k) + db(i,k)= min(db(i,k), dbmax) + enddo +!23456 + endif + enddo +!............................. +!............................. +! finish the mtn blocking +!............................. +!............................. +! +!--- OGW section +! +! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 +! inside "cires_ugwp_initialize.f90" now +! + kmpbl = km / 2 + iwk(1:npt) = 2 +! +! in meto/UK-scheme: +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations in taub_ogw +!23456 + do k=3,kmpbl + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb from the surface + enddo + enddo +! +! in all cires-UGWP-schemes: zogw > zobl +! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb +! the top of hill can be inside the PBL.... if kref = khtop +! + + kbps = 1 + kmps = km + k_mtb = 1 +!23456 + do i=1,npt + j = ipt(i) + k_mtb = max(1, idxzb(i)) + ! WRF/GSL: kogw = max(kpbl, ktop=2*var) + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime + kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime +!zogw > zobl + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! OGW-layer above the blocking height + kbps = max(kbps, kref(i)) + kmps = min(kmps, kref(i)) +! + delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + bnv2bar(i)= 0.0 + enddo +!23456===================== +! +!= we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb +!computation of the mean flow for zobl < z < ztop =sigfac*hprime inb GSL ztop =max(hpbl, ztop) +!23456===================== + do i = 1,npt + k_mtb = max(1, idxzb(i)) + do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) + if(k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo + enddo +! +! orographic asymmetry parameters (oa), and (clx) [Kim & Arakawa Kim & Doyle] +!23456 + do i = 1,npt + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) + clx(i) = clx4(j,mod(nwd-1,4)+1) ! number of "effective" hills (?) in the grid-box KA-95/KD-05 +! +!GSL-drag ->identical to above +! +! wdir = atan2(ubar(i),vbar(i)) + pi +! idir = mod(nint(fdir*wdir),mdir) + 1 +! nwd = nwdir(idir) +! oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) +! ol(i) = ol4(i,mod(nwd-1,4)+1) +! + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control Logic + ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) + xn(i) = ubar(i) / ulow(i) + yn(i) = vbar(i) / ulow(i) + enddo +!23456 + do k = 1, kmm1 + do i = 1,npt + j = ipt(i) + velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) + enddo + enddo + + do i = 1,npt + velco(i,km) = velco(i,kmm1) + enddo +! +!------------------------------------------------------------------------ +! v0/v1: incorporates modifications for kxridge and heff/hsat +! and employs taulin for fr <=fcrit_v1 +! concept of "clipped" hill if zmtb > 0. is uded to make +! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis +! now it is still used the "single-orowave" along ulow-upwind +! +! in contrast ifs/meto/e-canada employ the 2-orthogonal wave (2otw) schemes of +! it requires "aver angle" and wind projections on axes of ell-hill +! with 2-stresses: taub_a/b as suggested by analytics of Phillips (1984) +!------------------------------------------------------------------------ + + taub(:) = 0. ; taulin(:)= 0. ;taub_kd05 =0. + fcrit2 =fcrit_v1*fcrit_v1 +! +! taub_oro as in KA-95/KD-05 GSL & EMC includes ALL waves (POGWs, Lee-rotors, etc...) +! here taub represents mainly OGWs with nonh_fact = 1. -(kx/kz)**2 +! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered +!23456 + do i = 1,npt + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac + if (heff <= 0) cycle + zw1 = ulow(i)/bnv + hsat = fcrit_v1 *zw1 + heff = min(heff, hsat) + fr = heff/zw1 + fr = min(fr, frmax) + fr2 = fr*fr + zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) +! +! [Kim & Doyle, 2005] +! + efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream + efact = min( max(efact,efmin), efmax ) + gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 +! +! ! cleff_max(C768 = 6.28/(12.5 km/5.)) ..... +! xlinv(i) = min(coefm * cleff, cleff_max) +! + mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 + xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) + taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) +! +! old: tem = fr2*oc(j) ; gfobnv = gmax * tem / ((tem + cg)*bnv(i)) +! kx =or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge +! + sigres = sigma(j) + inv_b2eff = pi*sigres/heff ! pi2/(2b) + kxridge = pi /ahdxres(i) ! pi2/(2*dx) + xlingfs = max(inv_b2eff, kxridge) + nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 +!23456 + if (nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U +! + taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact + tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact +! +! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => +! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 +!23456 + if(fr > fcrit_v1 ) then + frnd = fr/fcrit_v1 + fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) + taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) + else + taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 + endif + xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 + k = max(1, kref(i)-1) + tem = max(velco(i,k)*velco(i,k), dw2min) + scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level Bn2/U2= kz^2 + zogw(j) = zmeti(j, kref(i) ) + tau_ogw(j) = taub(i) +!23456 + enddo +! +!----set up bottom values of stress +! + do i = 1,npt + taup(i, 1:kref(i) ) = taub(i) + enddo +!====================================================== +! +! Having : taub(i)/tau_ogw(j) => solve for OGW-effects +! +!====================================================== + if (strsolver == 'pss-1986') then + +!====================================================== +! v0-gfs orogw-solver of Palmer et al 1986 -"pss-1986" +! modified by KD05 with the emp.expression (11):below k=kref ??? +! tau(k+1) = tau(k)*Scorer(K+1)/Scorer(K) +! in v1-orogw linsatdis of "wam-2017" for +! rotational/non-hydrostat ogws; important for +! highres-fv3gfs with dx < 10 km +!23456====================================================== + do k = kmps, kmm1 ! vertical level loop from min(kref) + kp1 = k + 1 + do i = 1, npt + if (k >= kref(i)) then + icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) + endif + enddo +! + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + zw1 = max(velco(i,k), velmin) + temv = 1.0 / zw1 +!=============== +! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB only OA >0 +! k >= kref(i) and .... k+1 0. .and. kp1 < kref(i)) then + scork = bnv2(i,k) * temv * temv + rscor = min(1.0, scork / scor(i)) + scor(i) = scork + else + rscor = 1. + endif +!=============== + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv +! +! rim is the "wave"-richardson number byPalmer,Shutts & Swinbank 1986 , PSS-1986 +! + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check Ri-stability to employ the 'dynamical criterion' of PSS-1986 +! assuming co-existence of simultaneous Dyn-Ins and Conv-Ins +! cos(GW_phase) =1 and sin(GW_phase)=-1 +!23456 + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = zw1 * (2.*sqrt(temc)-temc) / brvf + taup(i,kp1) = tem1 * hd * hd + else + taup(i,kp1) = taup(i,k) * rscor + endif +! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) + endif ! k >= kref(i)) + enddo ! oro-points + enddo ! do k = kmps, kmm1 vertical level loop +!23456 +! zero momentum deposition at the top model layer: taup(k+1) = taup(k) +! + taup(1:npt,km+1) = taup(1:npt,km) +! +! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud +!23456 + do k = 1,km + do i = 1,npt + zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) +!====================================================================================== +! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hil +! apply limiters for OGW tendency +!====================================================================================== + if (abs(zw1) > max_axyz ) zw1 = sign(max_axyz, zw1) + taud(i,k)= zw1 + enddo + enddo +!23456 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!------if the gravity wave drag would force a critical line in the +!------layers below sigma=rlolev during the next deltim timestep, +!------then only apply drag until that critical line is reached. +! empirical implementation of the llwb-mechanism: lower level wave breaking +! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb +! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws +!2019: this option limits sensitivity of taux/tauy to variations in "taub" +!23456~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev .and. taud(i,k) /= 0.) then + tem = dtp * taud(i,k) + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +!default : dtfac(i) = 1.0 + endif + enddo + enddo +! +!--------- orogw-solver of gfs PSS-1986 is performed + else +!----------orogw-solver of wam2017 out : taup, taud, pkdis + + call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, omega1, rd, & + del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) + + endif ! oro_linsat - linsatdis-solver for stationary OGWs +! +!---- above orogw-solver of wam2017------------ +! +! tofd as in Beljaars-2004 IFS sep-scale ~5km +! CESM ~ 6km (TMS + OGW/OBL) +! sgh30 = varss of GSL +! ---------------------------------------------- +!23456 + if( do_tofd ) then + do i = 1,npt + j = ipt(i) + zpbl = zmet( j, kpbl(j) ) + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso GSL-2/limits a) 250 m ; b) var_maxfd =150m + zsurf = zmeti(j,1) + do k=1,km + zpm(k) = zmet(j,k) + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo + + call ugwp_tofd1d(km, cpd, dtp, sigflt, zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,km + dudt_ofd(j,k) = utofd1(k) + dvdt_ofd(j,k) = vtofd1(k) +! +! add tofd to gw-tendencies +! + pdvdt(j,k) = pdvdt(j,k) + utofd1(k) + pdudt(j,k) = pdudt(j,k) + vtofd1(k) + pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) + enddo + du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) + dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) + + dusfc(j) = dusfc(j) + du_ofdcol(j) + dvsfc(j) = dvsfc(j) + dv_ofdcol(j) + enddo + endif ! do_tofd +!23456 +!-------------------------------------------- +! combine oro-drag effects MB +TOFD + OGWs + diag-3d +!-------------------------------------------- +!234546 + do k = 1,km + do i = 1,npt + j = ipt(i) + eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) + if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then +! +! if blocking layers -- no ogw effects +! + dbim = db(i,k) / (1.+db(i,k)*dtp) + dudt_obl(j,k) = -dbim * u1(j,k) + dvdt_obl(j,k) = -dbim * v1(j,k) + + pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) + pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) + du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) + dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) + dusfc(j) = dusfc(j) + du_oblcol(j) + dvsfc(j) = dvsfc(j) + dv_oblcol(j) +!23456 + else +! +! ogw-s above blocking height +! + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) +! + dudt_ogw(j,k) = dtaux + dvdt_ogw(j,k) = dtauy +! + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) + +! + du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) + dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) +! + dusfc(j) = dusfc(j) + du_ogwcol(j) + dvsfc(j) = dvsfc(j) + dv_ogwcol(j) + endif +!23456 +!============ +! local energy deposition sso-heat due to loss of kinetic energy +!============ + unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) + enddo + enddo +! dusfc w/o tofd sign as in the era-i, merra and cfsr +!23456 + do i = 1,npt + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) + du_ogwcol(j) = -rgrav *du_ogwcol (j) + dv_ogwcol(j) = -rgrav *dv_ogwcol (j) + du_oblcol(j) = -rgrav *du_oblcol (j) + dv_oblcol(j) = -rgrav *dv_oblcol (j) + du_ofdcol(j) = -rgrav * du_ofdcol(j) + dv_ofdcol(j) = -rgrav * du_ofdcol(j) + enddo + + return + + +!============ print/debug after the RETURN statenemt -------------------------------- + if (kdt <= 2 .and. me == 0) then + print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' +! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' +! print *, maxval(zobl), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' + print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' +! print *, maxval(tau_tofd), ' tau_tofd ' +! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' +! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' + if (maxval(abs(pdudt))*86400. > 100.) then + + print *, maxval(u1), minval(u1), ' u1 gwdps-v1 ' + print *, maxval(v1), minval(v1), ' v1 gwdps-v1 ' + print *, maxval(t1), minval(t1), ' t1 gwdps-v1 ' + print *, maxval(q1), minval(q1), ' q1 gwdps-v1 ' + print *, maxval(del), minval(del), ' del gwdps-v1 ' + print *, maxval(zmet),minval(zmet), 'zmet' + print *, maxval(zmeti),minval(zmeti), 'zmeti' + print *, maxval(prsi), minval(prsi), ' prsi ' + print *, maxval(prsl), minval(prsl), ' prsl ' + print *, maxval(ro), minval(ro), ' ro-dens ' + print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' + print * + do i =1, npt + j= ipt(i) + print *,zogw(j)/hprime(j), zobl(j)/hprime(j), & + zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) +! + enddo + print * + stop + endif + endif + + return + end subroutine orogw_v1 +! +! + subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + + use machine , only : kind_phys + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! +! adding the implicit tendency estimate +! + implicit none + integer, intent(in) :: levs + real(kind_phys), intent(in) :: con_cp + real(kind_phys), intent(in) :: dtp + + real(kind_phys), intent(in), dimension(levs) :: u, v, zmid + real(kind_phys), intent(in) :: sigflt, zpbl, zsurf + + real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real(kind=kind_phys) :: rcpd2, tofd_mag, tofd_zdep + real(kind_phys) :: unew, vnew, eknew + + real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer + real(kind=kind_phys), parameter :: tend_imp = 1. + + + real(kind=kind_phys) :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed ~1.5 km +! H_efold = max(2*varss, hpbl) +! H_efold = min(H_efold,1500.) + rzdec = 1.0/zdec + + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! dz ~25m of the first layer in FV3GFS-127L + tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res + +! GSL-darg scheme: varmax_fd, beta_fd ,250. +! var_temp = MIN(varss,varmax_fd) + MAX(0., 0.1*(varss-varmax_fd)) +! var_temp = MIN(var_temp, 250.) +! var_temp = var_temp * var_temp +! +! a12=a1* 0.005363 * 0.0759 * 0.00026615161 +! +! rzdec 1./H_efold +! do k=1,levs +! zmet = zmid(k)-zsurf +! wsp=SQRT(u(k)*u(k) + v(k)*v(k)) ! abs(V) +! zarg = zmet*rzdec +! var_temp = var_temp * a12 * exp(-zarg*sqrt(zarg))*zmet**(-1.2) ! this > 0 +! krf = var_temp * wsp /(1. + var_temp*dtp*wsp) +! utofd(k) = -u(k) *krf +! vtofd(k) = -v(k)/(1. + var_temp*krf +! enddo + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + + ekin = u(k)*u(k) + v(k)*v(k) + + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg * sqrt(zarg)) + + tofd_zdep = zmet ** (-1.2) *ztexp + krf = umag * tofd_mag * tofd_zdep + + if (tend_imp == 1.) then + krf = krf/(1.+krf*dtp) + endif + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + if (tend_imp == 1.) then + unew =u(k)+ utofd(k)*dtp ; vnew =v(k)+ vtofd(k)*dtp + eknew =unew*unew + vnew*vnew + epstofd(k) = rcpd2*(ekin-eknew) + else + epstofd(k) = rcpd2*krf*ekin + endif + ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf ! can be used as addition to the mesoscale blocking + enddo +! + end subroutine ugwp_tofd1d + +end module cires_ugwpv1_oro diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 new file mode 100644 index 000000000..ee8f7bc83 --- /dev/null +++ b/physics/cires_ugwpv1_solv2.F90 @@ -0,0 +1,1037 @@ +module cires_ugwpv1_solv2 + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- + + subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & + tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & + xlatd, sinlat, coslat, & + pdudt, pdvdt, pdtdt, dked, zngw) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out +! -------------------------------------------------------------------------------- +! + use machine, only : kind_phys + + use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt + + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min +! + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + gw_eff, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +! + real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + integer, parameter :: ener_norm =0 + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + + real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(im) + real(kind=kind_phys) ,intent(in) :: coslat(im) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling + real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height +! +! +! +! local =========================================================================================== + + real(kind=kind_phys) :: tauabs(im,levs) ! + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux + real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density + real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind + real(kind=kind_phys) :: vint(levs+1) ! meridional wind + real(kind=kind_phys) :: tint(levs+1) ! temp-re + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + real(kind=kind_phys) :: v_zmet(levs+1) + real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax + + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met + real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti + + real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: Qmid, AKT + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + + integer, dimension(levs) :: Anstab + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + real(kind=kind_phys) :: rdci(nwav), rci(nwav) + real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level + real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level +! +! scalars +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + + + real(kind=kind_phys) :: flux_norm ! norm-factor + real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff +! + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode + real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real(kind=kind_phys) :: ucrit_max + real(kind=kind_phys) :: pwrms, ptrms + real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 + +! + real(kind=kind_phys) :: zdelp, zdelm, taud_min + real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: fmode, expdis, fdis + real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real(kind=kind_phys) :: v_wdi, v_wdpc + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + + real(kind=kind_phys) :: kamp, zmetk, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist + real(kind=kind_phys) :: w1, w2, w3, dtdif + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + real(kind=kind_phys) :: rstar, rstar2 + + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + +!-------------------------------------------------------------------------- +! + nslope3 = nslope + 3.0 + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw +! +! test for input fields +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif + + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + + suprf(ktop) = kion(levs) + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + jl =j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + aprsl(1:levs) = prsl(jl,1:levs) +! +! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" +! + do k=1, levs + if (aprsl(k) .lt. psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc= max(ilaunch, 3) + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + +!=====ksrc + + aum(km2:levs) = um(jl,km2:levs) + avm(km2:levs) = vm(jl,km2:levs) + atm(km2:levs) = tm(jl,km2:levs) + aqm(km2:levs) = qm(jl,km2:levs) + azmet(km2:levs) = zmet(jl,km2:levs) + aprsi(km2:levs+1) = prsi(jl,km2:levs+1) + azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) + + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch + + + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 +! +! compute diffusion-based arrays km2:levs +! + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1)-azmeti(jk) + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk)*(1. +fv*aqm(jk)) + tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0/(tvc+tvm) + rhp_wam = zthm*gor +!interface + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters +! +! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + + + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) + + akt(jk) = gipr/tvc + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi +! +! project winds at ksrc +! + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1:nazd, km2:ktop) =0. + + do inc=1,nwav + + zcin = zci(inc)*rstar + +! +! integrate (flux(cin) x dcin ) old tau-flux and normalization +! + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) +! +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo + + enddo +! +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + + ekin_norm = 1./snorm_ener + +! taub_src = sigu2 * rho_src * [v_kxw / zms ] +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo + +! copy flux-1 into other azimuths +! -------------------------------- + + + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! -------------------------------- + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) =0.0 +! +! wave_dis(iaz, :) = vueff(jk) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption +! + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + +! +! rotational cut-off +! + kzw2 = (bn2(jkp)-wdop2)/Cdf2 +! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds_sat = kxw*Cdf1*rhp2/kzw3 +!krad, kvg, kion, ktg + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc + +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 =0. + endif +! expdis =1.0 + + fdis = fmode*expdis*wave_act(inc,iaz) +!============================================================================== +! +! Saturated Fluxes and Energy: Spectral and Dicrete Modes +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! +! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) + +! +! +! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) +! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 +! [fden_bn(jkp)] = Pa/dc +! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] + + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] +! +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif +!---------------------------------------------------------------------------- +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +!---------------------------------------------------------------------------- + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if(zdep > 0.0 ) then +! subs on sat-limit + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer + else +! assign dis-ve flux + flux(inc,iaz) = fdis + endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif +! +! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" +! + if ( azmeti(jkp) .ge. zsp_gw) then + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + exp_sponge = exp(-ze1) +! +! additional sponge +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 +! +! sum for given (jk, iaz) all active "wave" contributions +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff + + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! +! compute wind and temp-re rms +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + +! -------------- + enddo ! end Azimuth do-loop + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) + ze1=max(dked_min, tx1) + ze2=min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) +! + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif +! + + do jk=ksrc+1,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +!maxdtdt= dked_max * bnfix2 +! + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo +!---------------------------------------------------------------------------------- +! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur +! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt +! can check "stability" in the column and "add" ktur-estimation +! to suppress instability as needed so dked = dked_gw + ktur_ric +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) + + do jk=ksrc,levs+1 + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + +! +! Thermal budget qmid = qheat + qcool +! + do jk=ksrc+1,levs + ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = qmid(jk)*rcpd + dked(jl, jk) = dktur(jk) + enddo +! +! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" +! from the surface/launch-gw to the "top" +! +! +! update by source function X(t+dt) = X(t) + dtp * dXdt +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! +! diagnose turb-profile using "stability-check" relying on the free-atm diffusion +! sc2 = 30m x 30m +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1./ze1 + + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) +! +! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur +! +! update of dked = dked_gw + k_turb_mf +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + +! +! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability +! + if (knob_ugwp_dokdis == 2) then + + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! +! k instead Jk +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! +! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs +! + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo +! +! compute "smoothed" tendencies by molecular + GW-eddy diffusions +! + do k=ksrc,levs-1 +! +! final updates of tendencies and diffusion +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + + enddo ! J-loop +! + RETURN + +!================================= diag print after "return" ====================== + if (kdt ==1 .and. mpi_id == master) then +! + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif +!================================= + return + end subroutine cires_ugwpv1_ngw_solv2 + + +end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 new file mode 100644 index 000000000..c840b49d8 --- /dev/null +++ b/physics/cires_ugwpv1_sporo.F90 @@ -0,0 +1,351 @@ + + subroutine oro_spectral_solver(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, rd +! + implicit none + + integer, intent(in) :: im, levs + integer, intent(in) :: npt + integer, intent(in) :: kdt, me, master + integer, intent(in) :: kref(im), ipt(im) + + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, & + hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: & + u1, v1, t1, bn2, rho, prsl, del + + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi +! +! out : taup, taud, pkdis +! + real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup + real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud + real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis +! +! multiwave oro-spectra +! locals +! + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real(kind=kind_phys) :: akx(nworo), cxoro(nworo), akx2(nworo) + real(kind=kind_phys) :: aspkx(nworo), c2f2(nworo), cdf2(nworo) + real(kind=kind_phys) :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real(kind=kind_phys) :: tau_kx(nworo),taub_kx(nworo) + + real(kind=kind_phys), dimension(nworo, levs+1) :: wrms, akzw + + real(kind=kind_phys) :: tauz(levs+1), rms_wind(levs+1) + real(kind=kind_phys) :: wave_act(nworo,levs+1) + + real(kind=kind_phys) :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real(kind=kind_phys) :: rayf, kturb + real(kind=kind_phys) :: uz, bv, bv2,kxsp, fcor2, cf2 + + real(kind=kind_phys) :: fdis + real(kind=kind_phys) :: wfdm, wfdt, wfim, wfit + real(kind=kind_phys) :: betadis, betam, betat, kds, cx, rhofac + real(kind=kind_phys) :: etwk, etws, tauk, cx2sat + real(kind=kind_phys) :: cdf1, tau_norm +! +! mean flow +! + real(kind=kind_phys), dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + real(kind=kind_phys) :: belps, aelps, nhills, selps + integer :: i, j, k, isp, iw + integer :: nw, nzi, ksrc + + + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then + write(6,771) maxval(tau_kx)*maxval(taub)*1.e3, minval(tau_kx), maxval(tau_kx) + endif +771 format( ' oro_spectral_solver ', 3(2x,F8.3)) +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & + & prsi(j,:), prsL(j,:), & + & 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 effects +! + kxw = akx(iw) + kzw = sqrt(kzw2) + akzw(iw,k) = kzw + kzw3 = kzw2*kzw + + cx = cxoro(iw) + betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + kds = wkdis(iw,k-1) + + etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) + + kturb = ktur(k)+pkdis(j,k-1) + wfiM = kturb*kzw2 +rayf + wfiT = wfiM ! do updates with Pr-numbers Kv/Kt + cdf1 = sqrt(Cdf2(iw)) + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cdf1)*BetaT + kzi = 2.*kzw*(wfdM+wfdT)*dzmet + Fdis = exp(-kzi) + + etwk = etws*Fdis + Cx2sat = Linsat2*Cdf2(iw) + + if (etwk > cx2sat) then + Kds = kxw*Cdf1*rhp2/kzw3 + etwk = cx2sat + wfiM = kds*kzw2 + wfdM = wfiM/(kxw*Cdf1) + kzi = 2.*kzw*(wfdm + wfdm)*dzmet + etwk = cx2sat*exp(-kzi) + endif +! if( lat(j) eq 40.5 ) then stop + wkdis(iw,k) = kds + wrms(iw,k) = etwk + tauk = etwk*kxw/kzw + tau_sp(iw,k) = tauk *rhoint + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) & + tau_sp(iw,k) = tau_sp(iw,k-1) + + ENDIF ! upward + ENDDO ! spectral + +!......... do spectral sum of rms, wkdis, tau + + tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) + rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau + + if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax + + ENDDO ! k=ksrc+1, levs + + k = ksrc + tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) + tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) + rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) + tauz(levs+1) = tauz(levs) + taup(i, 1:levs+1) = tauz(1:levs+1) + + do k=ksrc, levs + taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) +! +! limiters can be applied to avoid "large" wave accelerations +! +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +! + end subroutine oro_spectral_solver +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + use machine , only : kind_phys + use ugwp_common , only : velmin, dw2min, rdi, grav, rgrav, hpscale, rhp, rh4 + implicit none + + integer :: nz, nzi + real(kind=kind_phys), dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real(kind=kind_phys), dimension(nz ) :: bn2 ! define at the interfaces + real(kind=kind_phys), dimension(nz+1) :: pint + real(kind=kind_phys) :: xn, yn + +! output + + real(kind=kind_phys), dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real(kind=kind_phys) :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real(kind=kind_phys) :: zgrow, zmet, rdpm, ritur, kmol, w1 + +! paremeters +! real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 +! real(kind=kind_phys), parameter :: rhps=1.0/hps +! real(kind=kind_phys), parameter :: h4= 0.25/hps + + real(kind=kind_phys), parameter :: rimin = 0.125, kedmin = 0.01 + real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 + real(kind=kind_phys), parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + + kalp(1:nzi) = 2.e-7 ! radiative damping scale + + do k=2, nz + rdpm = grav/(pmid(k-1)-pmid(k)) + ui = .5*(u1(k-1)+u1(k)) + vi = .5*(v1(k-1)+v1(k)) + uzi(k) = ui*xn + vi*yn + 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 = -hpscale*alog(pint(k)*1.e-5) + zgrow = exp(zmet*rh4) + kmol = 2.e-5*exp(zmet*rhp) + kedmin + ritur = max(bn2(k)/shr2, rimin) + kamp = sqrt(shr2)*lsc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k) = kamp * w1 * w1 + kmol + enddo + + k = 1 + uzi(k) = uzi(k+1) + ktur(k) = ktur(k+1) + rhoi(k) = rdi*pint(k)/t1(k+1) + dzi(k) = rgrav*delp(k)/rhoi(k) + + k = nzi + uzi(k) = uzi(k-1) + ktur(k) = ktur(k-1) + rhoi(k) = rhoi(k-1)*.5 + dzi(k) = dzi(k-1) + + end subroutine oro_meanflow + diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 new file mode 100644 index 000000000..838ead1ee --- /dev/null +++ b/physics/cires_ugwpv1_triggers.F90 @@ -0,0 +1,330 @@ +module cires_ugwpv1_triggers + + use machine, only: kind_phys + +contains + +! +! +! +!>\ingroup cires_ugwp_run +!> @{ +!! +!! + subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) +!================= +! V1: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + integer :: i + +! +! if-lat +! + do i=1, im + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = 0.10 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_tamp_v1 +! + subroutine slat_geos5_2020(im, tau_amp, xlatdeg, tau_gw) +!================================================================= +! modified for FV3GFS-127L/C96 QBO-experiments +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) +!================================================================ + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + real(kind=kind_phys), parameter :: fampqbo = 1.25 ! 1.5 + real(kind=kind_phys), parameter :: famp60S = 1.0 ! 1.5 + real(kind=kind_phys), parameter :: famp60N = 1.0 ! 1.0 + real(kind=kind_phys), parameter :: famp30 = 0.25 ! 0.4 + + real(kind=kind_phys), parameter :: swid15 = 12.5 + real(kind=kind_phys), parameter :: swid60S = 30.0 ! 40 + real(kind=kind_phys), parameter :: swid60N = 25.0 ! 30 + integer :: i +! +! +! + do i=1, im + + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / swid15 + flat_gw = fampqbo * exp(-tem * tem) + if (latdeg <= 3.0) flat_gw = fampqbo + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = famp30 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60N* exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60N + flat_gw = famp60N * exp(- tem * tem) + endif + + if (xlatdeg(i) <= -31.0) then +! + if (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60S * exp(- tem * tem) + endif + if (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60S + flat_gw = famp60S * exp(- tem * tem) + endif + + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_2020 + + + subroutine slat_geos5(im, xlatdeg, tau_gw) + +!================= +! +! WAM: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +! +!================= + implicit none + integer :: im + real(kind=kind_phys) :: xlatdeg(im) + real(kind=kind_phys) :: tau_gw(im) + real(kind=kind_phys) :: latdeg + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys) :: trop_gw, flat_gw + integer :: i +! +! if-lat +! + trop_gw = 0.75 + do i=1, im + latdeg = xlatdeg(i) + if (-15.3 < latdeg .and. latdeg < 15.3) then + flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) + if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw + else if (latdeg > -31. .and. latdeg <= -15.3) then + flat_gw = 0.10 + else if (latdeg < 31. .and. latdeg >= 15.3) then + flat_gw = 0.10 + else if (latdeg > -60. .and. latdeg <= -31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg < 60. .and. latdeg >= 31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg <= -60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + else if (latdeg >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + end if + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5 + +!=============================================== +! +! Spontaneous GW triggers by dynamical inbalances (OKW, fronts/jets, and convection) +! not activated due to "limited" set of GFS-physics +! statein-type ( needs horizontal gradients of winds and temperature, humodity) +! +!=============================================== + subroutine get_spectra_tau_convgw & + (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) +! +! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function +! + integer :: nw, im, levs + integer,dimension(im,3) :: icld + real(kind=kind_phys), dimension(im, levs) :: dcheat, scheat + real(kind=kind_phys), dimension(im) :: precip, xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real(kind=kind_phys), parameter :: precip_max = 100. ! mm/day + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + + integer :: i, k, klow, ktop, kmid + real(kind=kind_phys) :: dtot, dmax, daver +! + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + do i=1, im + klow = icld(i,1) + ktop = icld(i,2) + kmid= icld(i,3) + if (klow == -99 .and. ktop == -99) then + cycle + else + klev(i) = ktop + k = klow + klev(i) = k + dmax = abs(dcheat(i,k) + scheat(i,k)) + do k=klow+1, ktop + dtot =abs(dcheat(i,k) + scheat(i,k)) + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! +! klev as max( dcheat(i,k) + scheat) +! vertical width of conv-heating +! +! counts/triiger=1 & taub(i) +! + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_amp* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! +! + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo + +! with info on precip/clouds/dc_heat create Bulk +! taub(im), klev(im) +! +! print *, ' get_spectra_tau_convgw ' + end subroutine get_spectra_tau_convgw +! + subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real(kind=kind_phys), dimension(im, levs) :: trig_fgf +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys), parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: fnorm, tau_min + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1.0 / float(kwidth) + tau_min = tau_amp*fnorm + do i=1, im +! +! only trop-c fjets so find max(trig_fgf) => klev +! use abs-values to scale tau_amp +! + + k = klow + klev(i) = k + dmax = abs(trig_fgf(i,k)) + kex = 0 + if (dmax >= tlim_fgf) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_fgf(i,k)) + if (dtot >= tlim_fgf) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo + + if (dmax .ge. tlim_fgf) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! print *, ' get_spectra_tau_nstgw ' + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 ! FV3-127L + enddo +! + end subroutine get_spectra_tau_nstgw +! + subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real(kind=kind_phys), dimension(im, levs) :: trig_okw +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch GWs should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 35.e-3 ! 35 mPa + real(kind=kind_phys), parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 ! for FV3-127L + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: fnorm, tau_min + + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1./float(kwidth) + tau_min = tau_amp*fnorm + print *, ' get_spectra_tau_okwgw ' + do i=1, im + k = klow + klev(i) = k + dmax = abs(trig_okw(i,k)) + kex = 0 + if (dmax >= tlim_okw) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_okw(i,k)) + if (dtot >= tlim_fgf ) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! + if (dmax >= tlim_okw) then + nf_src = nf_src + 1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo + print *, ' get_spectra_tau_okwgw ' + end subroutine get_spectra_tau_okw + +end module cires_ugwpv1_triggers diff --git a/physics/cires_vert_lsatdis.F90 b/physics/cires_vert_lsatdis.F90 deleted file mode 100644 index 362bed8ef..000000000 --- a/physics/cires_vert_lsatdis.F90 +++ /dev/null @@ -1,524 +0,0 @@ - subroutine ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & -! fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1) - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs, nw, naz, ksrc - real :: kxw - real, dimension(nw) :: taub_spect, ch - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - - real, dimension(levs+1 ) :: uaz - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - real, dimension(levs+1 ) :: taux, tauy - real, dimension(levs ) :: dzirho , dzpi - real :: usrc -! - integer :: iaz, k -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - - do k=1,levs - dzpi(k) = -(pint(k+1)-pint(k))/rho(k)*rgrav - dzirho(k) = 1./rho(k)/dzpi(k) ! grav/abs(dp(k)) still hydrostatic "UGWP" - enddo - - LOOP_IAZ: do iaz =1, naz - usrc = ui(ksrc)*xaz(iaz) +vi(ksrc)*yaz(iaz) - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) -usrc - enddo -! -! if (nw .le. 4) call stochastic ..ugwp_lsatdis_az1 only 4-waves ch_ngw1, fuw_ngw1, eff_ngw1=1 -! -! multi-wave scheme -! - if (nw .gt. 4) then - call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & - fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - endif -! - ENDDO LOOP_IAZ ! Azimuth of GW propagation directions -! -! sum over azimuth and project aTau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum(kedd(k,:)) - enddo - - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) -! -! end solver: gw_azimuth_solver_LS81 -! sign Ax in rho*dU/dt = -d(rho*tau)/dz -! [(k) - (k+1)] - ax =0. ; ay = 0. - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - return - -! - print * - print *, ' Ax: ', maxval(Ax(ksrc:levs))*86400., minval(Ax(ksrc:levs))*86400. - print *, ' Ay: ', maxval(Ay(ksrc:levs))*86400., minval(Ay(ksrc:levs))*86400. - print *, 'Eps: ', maxval(Eps(ksrc:levs))*86400., minval(Eps(ksrc:levs))*86400. - print *, 'Ked: ', maxval(Ked(ksrc:levs))*1., minval(Ked(ksrc:levs))*1. -! print *, 'Atau ', maxval(atau(ksrc:levs, 1:Naz))*1.e3, minval(atau(ksrc:levs, 1:Naz))*1.e3 -! print *, 'taux_gw: ', maxval(taux( ksrc:levs))*1.e3, minval(taux( ksrc:levs))*1.e3 - print * -!----------------------------------------------------------------------- -! Here we can apply "ad-hoc" or/and "stability-based" limiters on -! (axy_gw, ked_gw and eps_gw) and check vert-inegrated conservation laws: -! energy and momentum and after that => final update gw-phys tendencies -!----------------------------------------------------------------------- - - end subroutine ugwp_lsatdis_naz -! - subroutine ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_sp, & - fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) - -! call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & -! fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & -! kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - use cires_ugwp_module, only : F_coriol, F_nonhyd, F_kds, linsat, linsat2 - use cires_ugwp_module, only : iPr_ktgw, iPr_spgw, iPr_turb, iPr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! - implicit NONE -! - integer, intent(in) :: nw ! number of GW modes in given direction - integer, intent(in) :: levs ! vertical layers - integer, intent(in) :: ksrc ! level of GW-launch layer - - real , intent(in) :: kxw ! horizontal wavelength - real , intent(in) :: ch(nw) ! horizontal phase velocities - real , intent(in) :: taub_sp(nw) ! spectral distribution of the mom-flux -! - real, intent(in) :: fcor, c2f2 ! Corilois factors - - real , intent(in) :: um(levs+1) - real , intent(in) :: tm(levs+1) -!in - real, intent(in), dimension(levs) :: rho, zm - real, intent(in), dimension(levs+1) :: rhoi, zi - real, intent(in), dimension(levs+1) :: bn2, bn - real, intent(in), dimension(levs) :: dzpi, dzirho - real, intent(in), dimension(levs+1) :: kvg, ktg, krad, kion, kmol -!======================================================================== -!out - real, dimension(levs+1) :: tau, ked - real, dimension(levs) :: eps - -!========================================================================= -!local - real :: Fd1, Fd2 - real, dimension(levs) :: a_mkz - real, dimension(levs+1,nw) :: sp_tau, sp_ked, sp_kth - real, dimension(levs,nw) :: sp_eps - - real, dimension(levs,nw) :: sp_mkz, sp_etot - real, dimension(levs,nw) :: sp_ek, sp_ep - - - real, dimension(levs) :: swg_ep, swg_ek, swg_et, swg_kz - - real, dimension(nw) :: rtaus ! spectral distribution at ksrc - real :: sum_rtaus ! total flux in iaz-azimuth - real :: Chnorm, Cx, Cs, Cxs, Cx2sat - real :: Fdis, Fdisat - real :: Cdf2, Cdf1 ! (Cd*cd-f*f) and sqrt -! -! two-level => upward integration for wave-filtering (dissip + breaking) -! - real :: taus, tauk, tau_lin - real :: etws, etwk, etw_lin - real :: epss, epsk - real :: kds, kdk - real :: kzw, kzw2, kzw3, kzi, kzs - real :: wfd, wfi ! -! -! for GW dissipation on the rotational sphere -! - real :: Betadis ! Ep/Ek ratio - real :: BetaM, BetaT ! 0.5 or 1./1+b and 1-1/(1+b) - real :: wfdM, wfdT, wfiM, wfiT, wdop2 - - real :: dzi, keff, keff_m, keff_t, keffs - - real :: sf2k2, cf2 - real :: Lzkm, Lzsat - - integer :: i, k, igw - integer :: ksat1, ksat2 - - real :: zsat1, zsat2 - real :: kx2_nh - - real :: rab1, rab2, rab3, rab4, cd_ulim2 - - integer :: Ind_out(nw, levs+1) - -! - logical, parameter :: dbg_print = .false. -! -!=================================================================== -! Nullify arrays -! tau, eps, ked -!==================================================================== - - tau = 0.0 - eps = 0.0 - ked = 0.0 - Ind_out(1:nw,:) = 0 -! -! GW-spectral arrays ..... sp_etot ....sp_tau -! - sp_tau = 0. - sp_eps = 0. - sp_ked = 0. - sp_mkz = -99. - sp_etot = 0. - sp_ek = 0. - sp_ep = 0. - sp_kth = 0. -! - swg_et = 0. - swg_ep = 0. - swg_ek = 0. - swg_kz = 0. - cd_ulim2 = cd_ulim*cd_ulim - cf2 = F_coriol*c2f2 - kx2_nh = F_nonhyd*kxw*kxw - - if (dbg_print) then - write(6,*) linsat , ' eff-linsat & kx ', kxw - write(6,*) maxval(ch), minval(ch), ' ch ' - write(6,*) - write(6,*) maxval(rhoi), minval(rhoi), 'rhoi ' - write(6,*) zi(ksrc) , ' zi(ksrc) ' - write(6,*) cd_ulim, ' crit-level cd_ulim ' - write(6,*) F_coriol, ' F_coriol' - write(6,*) F_nonhyd, ' F_nonhyd ' - write(6,*) maxval(Bn), minval(BN), ' BN-BV ' - write(6,*) Um(ksrc), ' Um-ksrc ', cd_ulim2 , 'cd_ulim2 ', c2f2, ' c2f2 ' - !pause - endif - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Loop_GW: over GW-spectra -! of individual non-interactive modes -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - Loop_GW: do i=1, nw -! - Kds = 0.0 -! -! src-level -! - Cx = ch(i) - Um(ksrc) - Cdf2 = Cx*Cx - cf2 - taus = taub_sp(i) ! momentum flux for i-mode w/o rhoi(ksrc) - kzw = Bn(ksrc) / Ch(i) ! ch(i) > 0. Cx(i) < 0. critica - etws = taus*kzw / kxw - rtaus(i) = taus*rhoi(ksrc) -! - IF( Cx <= cd_ulim .or. Cdf2 <= cd_ulim2) THEN - Ind_out(i, ksrc) =-1 ! -1 - diagnostic index for critical levels - cycle Loop_GW ! got to the next mode of GW-spectra - ELSE -! - kzw2 = Bn2(ksrc)/Cdf2 - rhp4 - kx2_nh -! - if (kzw2 <= 0.) then - Ind_out(i, ksrc) =-2 ! -2 - diagnostic index for reflected waves - cycle Loop_GW ! no wave reflection in GW-LSD scheme - endif - - kzw = sqrt(kzw2) - kzw3 = kzw2*kzw - etws = taus*kzw/kxw -! -! Here Linsat == Fr_critical -! - Cx2sat = Linsat2*Cdf2 - if (etws >= cx2sat) then - Kds = kxw*Cx*rhp2/kzw3 - etws = cx2sat - taus = etws*kxw/kzw - Ind_out(i, ksrc) =-3 ! -3 - dignostic index for saturated waves - endif -! - betadis = cdf2/(Cx*Cx+cf2) - betaM = 1.0 /(1.0+betadis) - betaT = 1.0 - BetaM -! - Cxs = Cx - kzs = kzw -! keffs = (kvg(ksrc)+kds)*iPr_turb*.5*khp -! sp_kth(ksrc, i) = rhoi(ksrc)*keffs*(Tm(ksrc)+Tm(ksrc-1)) - rtaus(i) = taus*rhoi(ksrc) - sp_tau(ksrc, i) = rtaus(i) - sp_etot(ksrc, i) = etws - sp_mkz(ksrc, i) = kzw - sp_ek(ksrc, i) = etws*betam - sp_ep(ksrc, i) = etws*betaT ! can be transferred to (T'**2) T-rms - -! - ENDIF ! vertical propagation of i-mode to the next upper layer = (ksrc+1) -! -! Loop_Zint .................................. VERTICAL "INTERFACE" LOOP from ksrc => ktop_GW -! - Loop_Zi: do k=ksrc+1, levs -! - Cx = ch(i)-Um(k) ! Um(k) is defined at the interface pressure levels - Cdf2 = Cx*Cx -cf2 - if( Cx <= cd_ulim .or. Cdf2 <= 0.) then - Ind_out(i, k) =-1 ! 1 - diagnostic index for critical levels - ! print*,'crit level C-U ',int(Cx),int(sqrt(cf2)),' Um ',Um(k) - cycle Loop_GW - endif - - cdf1 =sqrt(Cdf2) - wdop2 = (kxw*Cx)* (kxw*Cx) - kzw2 = (Bn2(k)-wdop2)/Cdf2 - rhp4 - kx2_nh ! full lin DS-NIGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) - - if (kzw2 < 0.) then - Ind_out(i, k) =-2 ! 2 - diagnostic index for reflected waves - cycle Loop_GW - endif - kzw = sqrt(kzw2) - kzw3 =kzw2*kzw -! - keff_m = kvg(k)*kzw2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*kzw2 + krad(k) -! -! - betadis = cdf2 / (Cx*Cx+cf2) - betaM = 1.0 / (1.0+betadis) - betaT = 1.0 - BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*kzw2*F_kds + keff_m - wfiT = kds*iPr_ktgw*F_kds * kzw2 + keff_t -! - wfdM = wfiM/(kxw*Cdf1)*BetaM - wfdT = wfiT/(kxw*Cx)*BetaT -! exp-l: "kzi*dz" - kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) ! 2-factor energy-momentum (U')^2 -!------------------------------------------------------- -! dissipative factor: Fdis -! we can replace WKB-solver by Numerical integration of -! tau_gw == etot_gw/kzw*kxw -! d(rho*tau_gw) = -kdis*rho*tau_gw -! |tau_gw| <= |tau_gwsat| -! linear limit for single mode -! generalization for the "broad" spectra -! or treating single mode breaking -! over finite "vertical"-depth with "efficiency" -! Now: time-step + hor-l scale -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Fdis = exp(-kzi) -! -! -! dissipative "wave rms" by WKB -! - etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*kzw/kzs -! - Cx2sat = Linsat2*Cdf2 -! -! Linear saturation -! - if (etwk.ge.cx2sat) then - - Ind_out(i, k) =-3 ! 3 - dignostic index for saturated waves -! ! saturate energy and "trigger" keddy - etw_lin = etwk - etwk = cx2sat - Kds = kxw*Cdf1*rhp2/kzw3 - tauk = etwk*kxw/kzw - -!=================================================================================== -! WAM/case with high Kds tau_lin = (etw_lin-etwk)*kxw/kzw !tau_loss by sat theory -! Lzsat = 6,28/kzw Zsat1 = Zi(k)-.5*Lzsat -! Zsat2 = Zi(k)+.5*Lzsat -! in WAM triggering from "kds = 0 m2/s" => "200 m2/s" for Lzw ~ 10 km -! -! call sat_domain(zi, Zsat1, Zsat2, pver, ksat1, ksat2) -! -! to avoid it do the new diss-n factor with eddy "kds" added to the -! background keff_m and keff_t -! -! can be taken out for the strato-mesosphere in GFS -! wfiM = kds*kzw2 + keff_m -! wfiT = kds*iPr_ktgw * kzw2 +keff_t -! wfdM = wfiM/(kxw*Cdf1)*BetaM -! wfdT = wfiT/(kxw*Cx)*BetaT -! kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) -! Fdisat = exp(-kzi) -! etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*(kzw/Kzs) -! updated breaking in the Lzsat-domain: zsat1 < zi < zsat2 -! ================================================================================= - else - kds = 0.0 - tauk = etwk*kxw/kzw ! = Ekin*kx/kz - ENDIF -!-------------------------------------- -! -! Fill in spectral arrays(levs, nw) -! -!-------------------------------------- - sp_ked(k,i) = kds ! defined at interfaces - sp_tau(k, i) = tauk*rhoi(k) ! defined at interfaces - -! keff = (kds + kvg(k))*iPr_turb*0.5*KHP -! sp_kth(k, i) = rhoi(k)*keff*(Tm(k)+Tm(k-1)) ! defined at mid-layers - - sp_etot(k, i) = etwk ! defined at interfaces - sp_mkz(k, i) = kzw ! defined at interfaces - sp_ek(k, i) = etwk*betam ! defined at interfaces - sp_ep(k, i) = etwk*betaT ! can be transferred to (T'**2) -! -! - if (sp_tau(k,i) > sp_tau(k-1,i)) then - sp_tau(k,i) = sp_tau(k-1,i) ! prevent "possible" numerical "noise" - endif -! -! updates for "eps and keff" from -! - rab1 =.5*(cx+cxs)*dzirho(k) -! heating -! due to wave dissipation -! - sp_eps(k,i) = rab1*(sp_tau(k-1,i)- sp_tau(k,i)) ! defined at mid-layers -! -! cooling term due to eddy heat conduction =0 if Keff_cond =>0, -! usually updated by 1D-heat implict tridiagonal solver -! explicit local solver ---->sp_kth(k,i) = Kt*(dT/dz+ R/Cp*T/Hp~>g/cp) -! -! sp_eps(k,i)=sp_eps(k,i)+dzirho(k)*(sp_kth(k,i)- sp_kth(k-1,i)) -! - kzs = kzw - cxs = cX - taus = tauk - etws = etwk -! keffs = keff - - enddo Loop_Zi ! ++++++++++++++ vertical layer -! -! ................................! stop ' in solver single-mode' -! - enddo Loop_GW ! i-mode of GW-spectra -! - sum_rtaus =sum(rtaus) ! total momentum flux at k=ksrc - -! print *, sum_rtaus, ' tau-src ', nint(zi(ksrc)*1.e-3) -! print *, maxval(ch), minval(ch), ' Ch ', ngwv, ' N-modes ' -! -!============================================================================== -! Perform spectral integartion (sum) & apply "efficiency/inremittency" factors -! -! eff_factor: ~ 1./[number of modes in 1-direction of model columns] -! -!============================================================================== - do k=ksrc, levs - - ked(k) =0. - Eps(k) = 0. - Tau(k) = 0. - swg_et(k) =0. - swg_ep(k) =0. - swg_ek(k) =0. - - do i=1,nw - Ked(k) = Ked(k)+sp_ked(k,i) - Eps(k) = Eps(k)+sp_eps(k,i) - Tau(k) = Tau(k)+sp_tau(k,i) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! GW-energy + GW-en flux ~ Cgz*E, diagnostics-only -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - swg_et(k) = swg_et(k)+sp_etot(k,i) !*eff_fact - swg_ep(k) = swg_ep(k)+sp_ep(k,i) !*eff_fact - swg_ek(k) = swg_ek(k)+sp_ek(k,i) !*eff_fact - enddo - - enddo -! fill in below the "source" level ..... [1:ksrc-1] -! - do k=1, ksrc-1 -! no loss of the total momentum flux - ked(k) =0. - eps(k) = 0. - tau(k) = tau(ksrc) -! lin-theory diagnostics-only - swg_et(k) =swg_et(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ep(k) =swg_ep(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ek(k) =swg_ek(ksrc)*rhoi(ksrc)/rhoi(k) - enddo -! - RETURN -! -! diagnostics below -! -345 FORMAT(2x, F8.2, 4(2x, F10.3), 2x, F8.2) - if (dbg_print) then - print * - print *, ' Zkm EK m2/s2 Ked m2/s Eps m2/s3 tau-Mpa ' - do k=ksrc, levs -! Fd1 = maxval(Fdis_modes(1:nw,k)) -! Fd2 = minval(Fdis_modes(1:nw,k)) - write(6, 345) Zi(k)*1.e-3, sqrt(swg_ek(k)), Ked(k), Eps(k), Tau(k)*1.e3, Um(k) !, Fd1, Fd2 - enddo - print * - write(6,*) nw , ' nwaves-linsat ' - write(6,*) maxval(sp_ked), minval(sp_ked), 'ked ' - write(6,*) maxval(sp_tau), minval(sp_tau), 'sp_tau ' - !pause - endif - -! - end subroutine ugwp_lsatdis_az1 -! - subroutine ugwp_limit_1d(ax, ay,eps, ked, levs) - use cires_ugwp_module, only : max_kdis, max_eps, max_axyz - implicit none - integer :: levs - real, dimension(levs) :: ax, ay,eps - real, dimension(levs+1) :: ked - real, parameter :: xtiny = 1.e-30 - where (abs(ax) > max_axyz ) ax = ax/abs(ax+xtiny)*max_axyz - where (abs(ay) > max_axyz ) ay = ay/abs(ay+xtiny)*max_axyz - where (abs(eps) > max_eps ) eps = eps/abs(eps+xtiny)*max_eps - where (ked > max_kdis ) ked = max_kdis - end subroutine ugwp_limit_1d diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 deleted file mode 100644 index 0d3cce194..000000000 --- a/physics/cires_vert_orodis.F90 +++ /dev/null @@ -1,1018 +0,0 @@ -! subroutine ugwp_drag_mtb -! subroutine ugwp_taub_oro -! subroutine ugwp_oro_lsatdis -! - subroutine ugwp_drag_mtb( iemax, nz, & - elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) - - use ugwp_common, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init,only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver - - implicit none -!======================== -! several versions for drmtb => high froude mountain blocking -! version 1 => vay_2018 ; -! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 -! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 -!======================== - -! character(len=8) :: strver = 'vay_2018' -! real, parameter :: Fcrit_mtb = 0.7 - - integer, intent(in) :: nz - integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime - real , intent(out) :: taumtb - - integer , intent(out) :: idxzb - real, dimension(nz), intent(out) :: drmtb - - real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) - real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam - real, intent(in) :: zpbl - - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: zpi, pint -! - real, dimension(nz+1) :: zpi_zero - real, dimension(nz) :: zpm_zero - real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp - - real, dimension(nz) :: bn2, uds, umf, cosang, sinang - - integer :: k, klow, ktop, kpbl - real :: uhm, vhm, bn2hm, rhohm, & - mtb_fix, umag, bnmag, frd_src, & - zblk, who_iz_normal, rlm97, & - phiang, ang, pe, ek, & - cang, sang, ss2, cs2, zlen, dbtmp, & - hamp, bgamm, cgamm - -!================================================== -! -! elvp + hprime <=>elvp + nridge*hprime, ns =2 -! ns = sigfac -! tau_parel & tau_normal along major "axes" -! -! options to block the "flow", choices for [klow, ktop] -! -! 1-directional (normal) & 2-directional "blocking" -! -!================================================== -! no - blocking: drmtb(1:nz) = 0.0 -!================= - idxzb = -1 - drmtb(1:nz) = 0.0 - taumtb = 0.0 - klow = 2 - - ktop = iemax - hamp = nridge*hprime - -! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime - - mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - - if (mtb_fix == 0.) then - print *, cdmb, sigma, hamp - print *, ' MTB == 0' - stop - endif - - if (strver == 'vay_2018') then - - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - - do k=1, nz-1 - if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then - ktop = k+1 !......simply k+1 next interface level - exit - endif - enddo -! print *, klow, ktop, ' klow-ktop ' - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - if (bn2hm .le. 0.0) then - print *, ' unstable MF for MTB -RETURN ' - RETURN ! unstable PBL - endif - bnmag =sqrt(bn2hm) - - frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. - -! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' -! - if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking -! -! zblk > 0 -! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk -! - zblk = hamp*(1. - Fcrit_mtb/frd_src) - idxzb =1 - do k = 2, ktop - - if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then - idxzb = k - exit - endif - enddo -! - if (idxzb == 1) RETURN ! first surface level block is not "important" - - if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 -! -! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 -! - bgamm = 1.0 - 0.18*gam -0.04*gam*gam - cgamm = 0.48*gam +0.3*gam*gam - - do k = 1, idxzb-1 - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - - umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - - phiang = atan(vp(k)/umag) -! theta -90/90 - ang = theta - phiang - cang = cos(ang) ; sang = sin(ang) - - who_iz_normal = max(cang, gam*sang ) !gfs-2018 - - cs2 = cang* cang ; ss2 = 1.-cs2 - - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it -! - if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level -! - - who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS - - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - if (dbtmp < 0) dbtmp = 0.0 -! -! several approximation can be made to implement MTB-drag -! as a "nonlinear level dependent"-drag or "constant"-drag -! uds(k) == umag = const between the 1-layer and idxzb -! - - drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u - taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! -! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used -! with Umag-projections on A & B ellipse axes -! mtb_fix =0.25*cdmb*sigma/hprime, -! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. -! -!333 format(i4, 7(2x, F10.3)) -! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 - enddo -! - endif - endif ! strver=='vay_2018' -! -! -! - if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then - - print *, ' kdn_2005 with # of hills ' -! -! compute flow-blocking stress based on WRF 'gwdo2d' -! - endif -! -! - if (strver == 'gfs_2018') then - - ktop = iemax; klow = 2 - - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - if (bn2hm <= 0.0) RETURN ! unstable PBL -!--------------------------------------------- -! -!'gfs_2018' .... does not rely on Fr_crit -! and Fr-regimes -!----gfs17 for mtn ignores "averaging of the flow" -! for MTB-part it is only works with "angles" -! no projections on [uhm, vhm] -direction -! kpbl can be used for getting high values of iemax-hill -!----------------------------------------------------------- - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - do k=1, nz-1 - if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then - kpbl = k+1 - exit - endif - enddo - - do k = iemax, 1, -1 - - uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - phiang = atan(vp(k)/uds(k)) - ang = theta - phiang - cosang(k) = cos(ang) - sinang(k) = sin(ang) - - if (idxzb == 0) then - pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) - umf(k) = uds(k) * cosang(k) ! normal to main axis - ek = 0.5 * umf(k) * umf(k) -! -! --- dividing stream lime is found when pe =>exceeds ek first from the "top" -! - if (pe >= ek) idxzb = k - exit - endif - enddo - -! idxzb = min(kpbl, idxzb) -! -! -! -! last: mtb-drag -! - if (idxzb > 1) then - zblk = zpm(idxzb) - print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) - do k = idxzb-1, 1, -1 -! - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - cs2 = cosang(k)* cosang(k) - ss2 = 1.-cs2 - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it - - who_iz_normal = max(cosang(k), gam*sinang(k)) -! -! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) -! - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - - drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u -! - taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! - enddo - endif - endif ! strver=='gfs17' -! -! - end subroutine ugwp_drag_mtb -! -! -! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] -! -! - subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & - hprime , sigma, theta, oc, oa4, clx4, gamm, & - elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & - tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) -! - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin - use cires_ugwp_module, only : frcrit, ricrit, linsat - use ugwp_oro_init, only : hpmax, cleff, frmax - use ugwp_oro_init, only : nwdir, mdir, fdir - use ugwp_oro_init, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init, only : coro, nridge, odmin, odmax - use ugwp_oro_init, only : strver -! - use ugwp_oro_init, only : mkz2min, lzmax, zbr_pi -! --- -! -! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) -! approximate for drlee-momentum tendency -! --- - implicit none -! - integer, intent(in) :: levs, izb - real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero - integer, intent(out) :: kdswj, krefj, kotr - integer :: klwb - real, intent(in) :: kxw, fcor - real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp - -! - real, intent(in) :: oa4(4), clx4(4) - - real, dimension(levs), intent(in) :: up, vp, tp, qp, dp - real, dimension(levs+1), intent(in) :: zpi, pint - real, dimension(levs ), intent(in) :: zpm, pmid -! - real,dimension(levs), intent(out) :: drlee - real,dimension(levs+1), intent(out) :: tau_src -! - real, intent(out) :: tauogw, tautot, taulee - real :: taulin, tauhcr, taumtb - real, intent(out) :: xn, yn, umag, kxridge -! -! -! locals -! four possible versions to compute "taubase as a function of Fr-number" -! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' -! - real, dimension(levs+1) :: zpi_zero - - real :: oa, clx, odir, cl4p(4), clxp - - real :: uhm, vhm, bn2hm, rhohm, bnv - - real :: elvpMTB, wdir - real :: tem, efact, coefm, kxlinv, gfobnv - - real :: fr, frlin, frlin2, frlin3, frlocal, dfr - real :: betamax, betaf, frlwb, frmtb - integer :: klow, ktop, kph - - integer :: i, j, k, nwd, ind4, idir - - real :: sg_ridge, kx2, umd2 - real :: mkz, mkz2, zbr_mkz, mkzi - - real :: hamp ! clipped hprime*elvmax/elv_clip > hprime - real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) - real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves - real :: hcrit - real :: hblk ! blocking div-stream height - - real :: coef_h2, frnorm - - - real, dimension(levs) :: bn2 - real :: rho(levs) - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - real, dimension(levs+1) :: umd, phmkz - real :: c2f2, umag2, dzwidth, udir - real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp - real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms - real, dimension(levs+1) :: dtrans, deff - real :: pdtrans - logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 - logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum - ! between ZMTB => ZHILL -!----------------------------------------------------------------------------- -! -! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) -! ZMTB < ZOGW = ns*HPRIME < ELVP -! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB -! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new -! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW -! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB -! -!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] -! can be based on numerical runs like WRF-model -! for Frc < Fr< [Frc : 2.5-3 Frc] -! see suggestions proposed in SM-2000 and Eckermann et al. (2010) -!----------------------------------------------------------------------------- - tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 - krefj = 1 ; kotr = levs+1; kdswj = 1 - xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw - - dtrans = 0. ; deff =0. - klow = 2 - elvpMTB = elvp -! -! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB -! - if (izb > 0 ) then - klow = izb - elvpMTB = max(elvp - zpi(izb), 0.0) - endif - if (elvpMTB <=0 ) print *, ' blocked flow ' - if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX - - zpi_zero(:) = zpi(:) - zpi(1) - hblk = zpi_zero(klow) - - sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) - -! -! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp -! - sg_ridge = min(sg_ridge, hpmax) - -! print *, 'sg_ridge ', sg_ridge - - do k=1, levs - if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then - ktop = k+1 - exit - endif - enddo - - krefj = ktop ! the mountain top index for sg_ridge = ns*hprime - -! if ( izb > 0 .and. krefj .le. izb) then -! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' -! endif - -! -! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L -! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution -! - call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - call get_unit_vector(uhm, vhm, xn, yn, umag) - - if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment - bnv = sqrt(bn2hm) - hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer - hogw = hamp - hdsw = hamp - - - fr = bnv * hamp /umag - fr = min(fr, frmax) - kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx - kx2 = kxridge*kxridge - umag = max( umag, velmin) - c2f2 = fcor*fcor/kx2 - umag2 = umag*umag - c2f2 - - if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx - - mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" - ! and non-stationary waves coro, fcor for small umag - ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg - IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN -! -! case then no effects of wave-orography -! - krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 - tautot = 0. - tauogw = 0. - taulee = 0. - drlee = 0. ; tau_src(1:levs+1) = 0. - return - ENDIF -!========================================================================= -! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! make sure that SM_00 and KD_05 oro-characteristics can match each other -! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime -! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] -! alph-SM00 fraction of h2d contributed to hprime [0:1] -! -! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] -! delt-SM00 dw/up asymmetry -1 < delta < 1 -! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 -!.. -!A parametrization of low-level wave breaking which includes a dependence on -!the degree of 2-dimensionality of SG; it is active over a finite range of Fr -!========================================================================= - wdir = atan2(uhm,vhm) + pi - idir = mod( int(fdir*wdir),mdir) + 1 - - nwd = nwdir(idir) - ind4 = mod(nwd-1,4) + 1 - if (ind4 < 1 ) ind4 = 1 - if (ind4 > 4 ) ind4 = 4 - - oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) - clx = clx4(ind4) - cl4p(1) = clx4(2) - cl4p(2) = clx4(1) - cl4p(3) = clx4(4) - cl4p(4) = clx4(3) - clxp = cl4p(ind4) - - odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" - - odir = min(odmax, odir) - odir = max(odmin, odir) - - - if (strver == 'smc_2000' .or. strver == 'vay_2018') then -!========================================================================= -! -! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb -! taulin/tauogw taulee taumtb -! here tau_src(levs+1): approximate wave flux from surface to LLWB -! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) -!========================================================================= -! -! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 -! wave flux ~ rho_src*kx_src/mkz_src*wind_rms -! bn2, uhm, vhm, bn2hm, rhohm -! -! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN -! -! wave regimes -! - mkz = sqrt(mkz2) - frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb - frlin = fcrit_sm - frlin2 = 1.5*fcrit_sm - frlin3 = 3.0*fcrit_sm - - hcrit = fcrit_sm*umag/bnv - hogw = min(hamp, hcrit) - hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution - - coef_h2 = kxridge * rhohm * bnv * umag - - taulin = coef_h2 * hamp*hamp - tauhcr = coef_h2 * hcrit*hcrit - - IF (fr < frlin ) then - tauogw = taulin - taulee = 0.0 - taumtb = 0.0 - else if (fr .ge. frlin ) then - tauogw = tauhcr - taulin = coef_h2 * hamp*hamp - taumtb = tau_izb ! integrated form MTB -! -! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? -! - frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] - BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] - - if ( fr <= frlin2 ) then - Betaf= 2.*BetaMax*(frNorm-1.0) - taulee = (1. + Betaf )*taulin - tauhcr - else if ( (fr > frlin2).and.(fr <= frlin3))then - Betaf=-1.+ 1./frnorm/frnorm + & - (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) - taulee = (1. + Betaf )*taulin - tauhcr -!============== -! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) -! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) -! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) -! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) -! -!============== - else - taulee = 0.0 - hdsw = 0.0 - endif - ENDIF - - tautot = tauogw + taulee + taumtb*0. - - IF (taulee > 0.0 ) THEN - - hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge -! -! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves -! make "empirical" height above elvp that may represent DSW-wave breaking & trapping -! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge -! - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) ! kph marks the low-level of wave solutions - klwb = kph ! klwb above blocking marks wave-breaking - kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level - - if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) - - udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) - hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) - umd(krefj) = udir - - udir = max(ui(kph)*xn +vi(kph)*yn, velmin) - hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) - umd(kph) = udir - ! what we can put between k =[kph:krefj] - phmkz(:) = 0.0 ! - phmkz(kph-1) = fr ! initial Phase of the low-level wave -! -! now transfer tau_layer => tau_level assuming tau_layer = tau_level -! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT -! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 -! - loop_lwb_otr: do k=kph+1, krefj ! levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, dw2min) -c2f2 - - - if (umd2 <= 0.0) then -! -! critical layer -! - klwb = k - kotr = k - exit loop_lwb_otr - endif - - mkz2 = bn2i(k)/umd2 - kx2 - - if ( mkz2 >= mkz2min ) then -! -! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 -! at finest vertical resolution we can meet "abrupt" mkz -! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km -! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) -! - mkz = sqrt(mkz2) - hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) - udswz = hdswz *bn2i(k) -!=========================================================================================== -!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 -! -! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz -! by k = krefj tautot = tauogw(krefj) -!=========================================================================================== - if (do_klwb_phase) then - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then - klwb = min(k, krefj) - exit loop_lwb_otr - endif - endif - else ! mkz2 < mkz2min - kotr = k ! trapped/reflected waves / - exit loop_lwb_otr - endif - enddo loop_lwb_otr -! -! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee -! tau_trapped ??? -! - if (do_klwb_phase) then - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif -! -! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) -! more complicated is dissipative saturation pdtrans =/= constant -! - if (do_dtrans) then - do k=kph, krefj - tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) - drlee(k) = -tau_src(k)/rho(k) * pdtrans - enddo - endif - - - ENDIF !taulee > 0.0 - - - endif !strver -! - -!========================================================================= - if (strver == 'gfs_2018' .or. strver == 'kd_2005') then -!========================================================================= -! -! orowaves: OGW+DSW/Lee -! - efact = (oa + 2.0) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + clx) ** (oa+1.) - - kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx - kxlinv = coefm * cleff - tem = fr * fr * oc - gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 -!========================================================================= -! source fluxes: taulin, taufrb -!========================================================================= - tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact - - coef_h2 = kxlinv *rhohm * bnv*umag - taulin = coef_h2 *hamp*hamp - hcrit = fcrit_gfs*umag/bnv - tauhcr = coef_h2 *hcrit*hcrit - - IF (fr <= fcrit_gfs) then - tauogw = taulin - tautot = taulin - taulee = 0. - drlee(:) = 0. - ELSE !fr > fcrit_gfs - tauogw = tauhcr - taulee = max(tautot - tauogw, 0.0) - if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) -! approximate drlee(k) between [izb, klwb] -! find klwb and decrease taulee(izb) => taulee(klwb) = 0. -! above izb tau - if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then - - mkz = sqrt(mkz2) - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) - phmkz(:) = 0.0 - klwb = max(izb, 1) - kotr = levs+1 - phmkz(kph-1) = fr ! initial Phase of the Lee-OGW - - loop_lwb_gfs18: do k=kph, levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, velmin*velmin) - mkz2 = bn2i(k)/umd2 - kx2 - if ( mkz2 > mkz2min ) then - mkz = sqrt(mkz2) - frlocal = max(hdsw*bvi(k)/umd(k), frlwb) - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k - else - kotr = k - exit loop_lwb_gfs18 - endif - enddo loop_lwb_gfs18 -! -! - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 - ENDIF !fr > fcrit_gfs - - - ENDIF !strbase='gfs2017' .or. strbase='kd_2005' - - -! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge -! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' -! - end subroutine ugwp_taub_oro -! -!-------------------------------------- -! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & -! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & -! xn, yn, umag, drtau, kdis_oro) - - subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - xn, yn, umag, drtau, kdis) - - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav - use cires_ugwp_module, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module, only : kvg, ktg, krad, kion - use ugwp_oro_init, only : coro , fcrit_sm , fcrit_sm2 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - real , dimension(levs+1) :: tau_src - - real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm - real, dimension(levs+1), intent(in) :: zpi, pmid, pint - real , intent(in) :: xn, yn, umag - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: uref, udir, uf2, ufd, uf2p - real, dimension(levs+1) :: tauz - real, dimension(levs) :: rho - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, kcrit, kref - real :: kx2, kx2w, kxs - real :: mkzm, mkz, dkz, mkz2, ch, kzw3 - real :: wfdM, wfdT, wfiM, wfiT - real :: fdis, mkzi, keff_m, keff_t - real :: betadis, betam, betat, cdfm, cdft - real :: fsat, hsat, hsat2, kds , c2f2 - - drtau(1:levs) = 0.0 - kdis (1:levs) = 0.0 - - ch = coro - - kx2w = kxw*kxw - kx2 = kxridge*kxridge - if( kx2 < kx2w ) kx2 = kx2w - kxs = sqrt(kx2) - c2f2 = fcor*fcor/kx2 -! -! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) -! -! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -!=============================================================================== -! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 -! rotational/non-hyrostatic effects are important only for high-res runs -! Udir = 0, Udir < 0 are not -! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz -! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) -! stochastic "tauogw'-setup+ sigma_tau ; -! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves -! target is to get "multiple"-saturation levels for OGWs -!=============================================================================== - tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode - ! sign of tauz > 0...and its attenuate with Z - k = krefj - uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves - uf2 = uref*uref - c2f2 - if (uf2 > 0) then - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2.gt.0) then - mkzm = sqrt(mkz2) - else - return ! wave reflection mkz2 <=0. - endif - else - return ! wave absorption uf2 <= 0. - endif -! -! upward solver for single "mode" with tauz(levs+1) =0. at the top -! - kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer - kcrit = levs - do k= krefj+1, levs -! -! 2D-wave propagation along reference-wind direction -! udir = 0 critical wind for coro =0 -! cdop = -uref .... upwind waves travel against MF -! - udir = ui(k)*xn +vi(k)*yn - uf2 = udir*udir - c2f2 - - - if (uf2 < dw2min .or. udir <= 0.0) then - kcrit =K - tauz(kcrit:levs) = 0. - exit ! vert-level loop - endif -! -! wave-based solution -! - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2 > 0) then - mkzm = sqrt(mkz2) -! -! do dissipative flux vs saturation: kvg, ktg, krad, kion -! - kzw3 = mkzm*mkz2 -! - keff_m = kvg(k)*mkz2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*mkz2 + krad(k) -! -! - uf2p = uf2 + 2.0*c2f2 - betadis = uf2/uf2p - betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw - betaT = 1.0- BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*mkz2 + keff_m - wfiT = kds*mkz2 + keff_t -! - cdfm = sqrt(uf2)*kxs - cdft = abs(udir)*kxs - wfdM = wfiM/cdfm *BetaM - wfdT = wfiT/Cdft *BetaT - mkzi = 2.0*mkzm*(wfdM+wfdT) - - fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) - tauz(k) = fdis - hsat2 = fcrit_sm2 * uf2 *bn2i(k) - fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) - if (fdis > fsat) then - tauz(k) = min(fsat, tauz(k-1)) -!================================================================= -! two definitions for eddy mixing of MF: -! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 -! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 -!================================================================= - kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) - kdis(k) = kds - endif - else - tauz(k:levs) = 0. ! wave is reflected above - kds = 0. - endif - enddo - - do k=krefj+1, kcrit - drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) - enddo -! -! - end subroutine ugwp_oro_lsatdis -! -! - subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none -! - integer :: im, levs - real(kind_phys), dimension(im, levs) :: u, v, zmid - real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl - real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sgh = 30. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - - do i=1, im - - zdec = max(n_tofd*sigflt(i), zpbl(i)) - zdec = min(ze_tofd, zdec) - rzdec = 1.0/zdec - sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) - - do k=1, levs - zmet = zmid(i,k) - if (zmet > ztop_tofd) cycle - ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) - umag = sqrt(ekin) - zarg = zmet*rzdec - zexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp - utofd(i,k) = -krf*u(i,k) - vtofd(i,k) = -krf*v(i,k) - epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re - krf_tofd(i,k) = krf - enddo - enddo -! - end subroutine ugwp_tofd -! -! - subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none - integer :: levs - real(kind_phys), dimension(levs) :: u, v, zmid - real(kind_phys) :: sigflt, elvmax, zpbl, zsurf - real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sghmax = 5. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl - zdec = min(ze_tofd, zdec) ! cannot exceed 18 km - rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - - do k=1, levs - zmet = zmid(k)-zsurf - if (zmet > ztop_tofd) cycle - ekin = u(k)*u(k) + v(k)*v(k) - umag = sqrt(ekin) - zarg = zmet*rzdec - ztexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp - - utofd(k) = -krf*u(k) - vtofd(k) = -krf*v(k) - epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re; epstofd(k) can be skipped - krf_tofd(k) = krf - enddo -! - end subroutine ugwp_tofd1d diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 deleted file mode 100644 index 852c114b0..000000000 --- a/physics/cires_vert_orodis_v1.F90 +++ /dev/null @@ -1,1047 +0,0 @@ -module cires_vert_orodis_v1 - - -contains - - -! subroutine ugwp_drag_mtb -! subroutine ugwp_taub_oro -! subroutine ugwp_oro_lsatdis -! - subroutine ugwp_drag_mtb( iemax, nz, & - elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) - - use ugwp_common_v1, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init_v1, only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver - - implicit none -!======================== -! several versions for drmtb => high froude mountain blocking -! version 1 => vay_2018 ; -! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 -! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 -!======================== -! real, parameter :: Fcrit_mtb = 0.7 - - integer, intent(in) :: nz - integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime - real , intent(out) :: taumtb - - integer , intent(out) :: idxzb - real, dimension(nz), intent(out) :: drmtb - - real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) - real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam - real, intent(in) :: zpbl - - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: zpi, pint - - ! character(len=*), intent(out) :: errmsg - ! integer, intent(out) :: errflg -! - real, dimension(nz+1) :: zpi_zero - real, dimension(nz) :: zpm_zero - real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp - - real, dimension(nz) :: bn2, uds, umf, cosang, sinang - - integer :: k, klow, ktop, kpbl - real :: uhm, vhm, bn2hm, rhohm, & - mtb_fix, umag, bnmag, frd_src, & - zblk, who_iz_normal, rlm97, & - phiang, ang, pe, ek, & - cang, sang, ss2, cs2, zlen, dbtmp, & - hamp, bgamm, cgamm - - - ! Initialize CCPP error handling variables - ! errmsg = '' - ! errflg = 0 - -!================================================== -! -! elvp + hprime <=>elvp + nridge*hprime, ns =2 -! ns = sigfac -! tau_parel & tau_normal along major "axes" -! -! options to block the "flow", choices for [klow, ktop] -! -! 1-directional (normal) & 2-directional "blocking" -! -!================================================== -! no - blocking: drmtb(1:nz) = 0.0 -!================= - idxzb = -1 - drmtb(1:nz) = 0.0 - taumtb = 0.0 - klow = 2 - - ktop = iemax - hamp = nridge*hprime - -! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime - - mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - - ! if (mtb_fix == 0.) then - ! write(errmsg,'(*(a))') cdmb, sigma, hamp, ' MTB == 0' - ! errflg = 1 - ! return - ! endif - - if (strver == 'vay_2018') then - - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - - do k=1, nz-1 - if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then - ktop = k+1 !......simply k+1 next interface level - exit - endif - enddo -! print *, klow, ktop, ' klow-ktop ' - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - ! if (bn2hm .le. 0.0) then - ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' - ! errflg = 1 - ! return ! unstable PBL - ! end if - - bnmag =sqrt(bn2hm) - - frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. - -! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' -! - if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking -! -! zblk > 0 -! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk -! - zblk = hamp*(1. - Fcrit_mtb/frd_src) - idxzb =1 - do k = 2, ktop - - if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then - idxzb = k - exit - endif - enddo -! - if (idxzb == 1) RETURN ! first surface level block is not "important" - - if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 -! -! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 -! - bgamm = 1.0 - 0.18*gam -0.04*gam*gam - cgamm = 0.48*gam +0.3*gam*gam - - do k = 1, idxzb-1 - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - - umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - - phiang = atan(vp(k)/umag) -! theta -90/90 - ang = theta - phiang - cang = cos(ang) ; sang = sin(ang) - - who_iz_normal = max(cang, gam*sang ) !gfs-2018 - - cs2 = cang* cang ; ss2 = 1.-cs2 - - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it -! - if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level -! - - who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS - - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - if (dbtmp < 0) dbtmp = 0.0 -! -! several approximation can be made to implement MTB-drag -! as a "nonlinear level dependent"-drag or "constant"-drag -! uds(k) == umag = const between the 1-layer and idxzb -! - - drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u - taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! -! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used -! with Umag-projections on A & B ellipse axes -! mtb_fix =0.25*cdmb*sigma/hprime, -! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. -! -!333 format(i4, 7(2x, F10.3)) -! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 - enddo -! - endif - endif ! strver=='vay_2018' -! -! -! - if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then - - print *, ' kdn_2005 with # of hills ' -! -! compute flow-blocking stress based on WRF 'gwdo2d' -! - endif -! -! - if (strver == 'gfs_2018') then - - ktop = iemax; klow = 2 - - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - if (bn2hm <= 0.0) RETURN ! unstable PBL -!--------------------------------------------- -! -!'gfs_2018' .... does not rely on Fr_crit -! and Fr-regimes -!----gfs17 for mtn ignores "averaging of the flow" -! for MTB-part it is only works with "angles" -! no projections on [uhm, vhm] -direction -! kpbl can be used for getting high values of iemax-hill -!----------------------------------------------------------- - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - do k=1, nz-1 - if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then - kpbl = k+1 - exit - endif - enddo - - do k = iemax, 1, -1 - - uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - phiang = atan(vp(k)/uds(k)) - ang = theta - phiang - cosang(k) = cos(ang) - sinang(k) = sin(ang) - - if (idxzb == 0) then - pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) - umf(k) = uds(k) * cosang(k) ! normal to main axis - ek = 0.5 * umf(k) * umf(k) -! -! --- dividing stream lime is found when pe =>exceeds ek first from the "top" -! - if (pe >= ek) idxzb = k - exit - endif - enddo - -! idxzb = min(kpbl, idxzb) -! -! -! -! last: mtb-drag -! - if (idxzb > 1) then - zblk = zpm(idxzb) - print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) - do k = idxzb-1, 1, -1 -! - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - cs2 = cosang(k)* cosang(k) - ss2 = 1.-cs2 - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it - - who_iz_normal = max(cosang(k), gam*sinang(k)) -! -! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) -! - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - - drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u -! - taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! - enddo - endif - endif ! strver=='gfs17' -! -! - end subroutine ugwp_drag_mtb -! -! -! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] -! -! - subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & - hprime , sigma, theta, oc, oa4, clx4, gamm, & - elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & - tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) -! - use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin - use ugwp_common_v1, only : mkz2min, mkzmin - use cires_ugwp_module_v1, only : frcrit, ricrit, linsat - use ugwp_oro_init_v1, only : hpmax, cleff, frmax - use ugwp_oro_init_v1, only : nwdir, mdir, fdir - use ugwp_oro_init_v1, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init_v1, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init_v1, only : coro, nridge, odmin, odmax - use ugwp_oro_init_v1, only : strver -! - use ugwp_oro_init_v1, only : zbr_pi -! --- -! -! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) -! approximate for drlee-momentum tendency -! --- - implicit none -! - integer, intent(in) :: levs, izb - real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero - integer, intent(out) :: kdswj, krefj, kotr - integer :: klwb - real, intent(in) :: kxw, fcor - real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp - -! - real, intent(in) :: oa4(4), clx4(4) - - real, dimension(levs), intent(in) :: up, vp, tp, qp, dp - real, dimension(levs+1), intent(in) :: zpi, pint - real, dimension(levs ), intent(in) :: zpm, pmid -! - real,dimension(levs), intent(out) :: drlee - real,dimension(levs+1), intent(out) :: tau_src -! - real, intent(out) :: tauogw, tautot, taulee - real :: taulin, tauhcr, taumtb - real, intent(out) :: xn, yn, umag, kxridge -! -! -! locals -! four possible versions to compute "taubase as a function of Fr-number" -! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' -! - real, dimension(levs+1) :: zpi_zero - - real :: oa, clx, odir, cl4p(4), clxp - - real :: uhm, vhm, bn2hm, rhohm, bnv - - real :: elvpMTB, wdir - real :: tem, efact, coefm, kxlinv, gfobnv - - real :: fr, frlin, frlin2, frlin3, frlocal, dfr - real :: betamax, betaf, frlwb, frmtb - integer :: klow, ktop, kph - - integer :: i, j, k, nwd, ind4, idir - - real :: sg_ridge, kx2, umd2 - real :: mkz, mkz2, zbr_mkz, mkzi - - real :: hamp ! clipped hprime*elvmax/elv_clip > hprime - real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) - real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves - real :: hcrit - real :: hblk ! blocking div-stream height - - real :: coef_h2, frnorm - - - real, dimension(levs) :: bn2 - real :: rho(levs) - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - real, dimension(levs+1) :: umd, phmkz - real :: c2f2, umag2, dzwidth, udir - real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp - real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms - real, dimension(levs+1) :: dtrans, deff - real :: pdtrans - logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 - logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum - ! between ZMTB => ZHILL -!----------------------------------------------------------------------------- -! -! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) -! ZMTB < ZOGW = ns*HPRIME < ELVP -! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB -! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new -! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW -! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB -! -!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] -! can be based on numerical runs like WRF-model -! for Frc < Fr< [Frc : 2.5-3 Frc] -! see suggestions proposed in SM-2000 and Eckermann et al. (2010) -!----------------------------------------------------------------------------- - tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 - krefj = 1 ; kotr = levs+1; kdswj = 1 - xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw - - dtrans = 0. ; deff =0. - klow = 2 - elvpMTB = elvp -! -! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB -! - if (izb > 0 ) then - klow = izb - elvpMTB = max(elvp - zpi(izb), 0.0) - endif - if (elvpMTB <=0 ) print *, ' blocked flow ' - if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX - - zpi_zero(:) = zpi(:) - zpi(1) - hblk = zpi_zero(klow) - - sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) - -! -! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp -! - sg_ridge = min(sg_ridge, hpmax) - -! print *, 'sg_ridge ', sg_ridge - - do k=1, levs - if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then - ktop = k+1 - exit - endif - enddo - - krefj = ktop ! the mountain top index for sg_ridge = ns*hprime - -! if ( izb > 0 .and. krefj .le. izb) then -! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' -! endif - -! -! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L -! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution -! - call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - call get_unit_vector(uhm, vhm, xn, yn, umag) - - if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment - bnv = sqrt(bn2hm) - hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer - hogw = hamp - hdsw = hamp - - - fr = bnv * hamp /umag - fr = min(fr, frmax) - kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx - kx2 = kxridge*kxridge - umag = max( umag, velmin) - c2f2 = fcor*fcor/kx2 - umag2 = umag*umag - c2f2 - - if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx - - mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" - ! and non-stationary waves coro, fcor for small umag - ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg - IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN -! -! case then no effects of wave-orography -! - krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 - tautot = 0. - tauogw = 0. - taulee = 0. - drlee = 0. ; tau_src(1:levs+1) = 0. - return - ENDIF -!========================================================================= -! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! make sure that SM_00 and KD_05 oro-characteristics can match each other -! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime -! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] -! alph-SM00 fraction of h2d contributed to hprime [0:1] -! -! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] -! delt-SM00 dw/up asymmetry -1 < delta < 1 -! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 -!.. -!A parametrization of low-level wave breaking which includes a dependence on -!the degree of 2-dimensionality of SG; it is active over a finite range of Fr -!========================================================================= - wdir = atan2(uhm,vhm) + pi - idir = mod( int(fdir*wdir),mdir) + 1 - - nwd = nwdir(idir) - ind4 = mod(nwd-1,4) + 1 - if (ind4 < 1 ) ind4 = 1 - if (ind4 > 4 ) ind4 = 4 - - oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) - clx = clx4(ind4) - cl4p(1) = clx4(2) - cl4p(2) = clx4(1) - cl4p(3) = clx4(4) - cl4p(4) = clx4(3) - clxp = cl4p(ind4) - - odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" - - odir = min(odmax, odir) - odir = max(odmin, odir) - - - if (strver == 'smc_2000' .or. strver == 'vay_2018') then -!========================================================================= -! -! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb -! taulin/tauogw taulee taumtb -! here tau_src(levs+1): approximate wave flux from surface to LLWB -! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) -!========================================================================= -! -! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 -! wave flux ~ rho_src*kx_src/mkz_src*wind_rms -! bn2, uhm, vhm, bn2hm, rhohm -! -! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN -! -! wave regimes -! - mkz = sqrt(mkz2) - frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb - frlin = fcrit_sm - frlin2 = 1.5*fcrit_sm - frlin3 = 3.0*fcrit_sm - - hcrit = fcrit_sm*umag/bnv - hogw = min(hamp, hcrit) - hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution - - coef_h2 = kxridge * rhohm * bnv * umag - - taulin = coef_h2 * hamp*hamp - tauhcr = coef_h2 * hcrit*hcrit - - IF (fr < frlin ) then - tauogw = taulin - taulee = 0.0 - taumtb = 0.0 - else if (fr .ge. frlin ) then - tauogw = tauhcr - taulin = coef_h2 * hamp*hamp - taumtb = tau_izb ! integrated form MTB -! -! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? -! - frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] - BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] - - if ( fr <= frlin2 ) then - Betaf= 2.*BetaMax*(frNorm-1.0) - taulee = (1. + Betaf )*taulin - tauhcr - else if ( (fr > frlin2).and.(fr <= frlin3))then - Betaf=-1.+ 1./frnorm/frnorm + & - (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) - taulee = (1. + Betaf )*taulin - tauhcr -!============== -! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) -! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) -! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) -! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) -! -!============== - else - taulee = 0.0 - hdsw = 0.0 - endif - ENDIF - - tautot = tauogw + taulee + taumtb*0. - - IF (taulee > 0.0 ) THEN - - hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge -! -! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves -! make "empirical" height above elvp that may represent DSW-wave breaking & trapping -! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge -! - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) ! kph marks the low-level of wave solutions - klwb = kph ! klwb above blocking marks wave-breaking - kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level - - if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) - - udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) - hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) - umd(krefj) = udir - - udir = max(ui(kph)*xn +vi(kph)*yn, velmin) - hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) - umd(kph) = udir - ! what we can put between k =[kph:krefj] - phmkz(:) = 0.0 ! - phmkz(kph-1) = fr ! initial Phase of the low-level wave -! -! now transfer tau_layer => tau_level assuming tau_layer = tau_level -! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT -! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 -! - loop_lwb_otr: do k=kph+1, krefj ! levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, dw2min) -c2f2 - - - if (umd2 <= 0.0) then -! -! critical layer -! - klwb = k - kotr = k - exit loop_lwb_otr - endif - - mkz2 = bn2i(k)/umd2 - kx2 - - if ( mkz2 >= mkz2min ) then -! -! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 -! at finest vertical resolution we can meet "abrupt" mkz -! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km -! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) -! - mkz = sqrt(mkz2) - hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) - udswz = hdswz *bn2i(k) -!=========================================================================================== -!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 -! -! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz -! by k = krefj tautot = tauogw(krefj) -!=========================================================================================== - if (do_klwb_phase) then - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then - klwb = min(k, krefj) - exit loop_lwb_otr - endif - endif - else ! mkz2 < mkz2min - kotr = k ! trapped/reflected waves / - exit loop_lwb_otr - endif - enddo loop_lwb_otr -! -! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee -! tau_trapped ??? -! - if (do_klwb_phase) then - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif -! -! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) -! more complicated is dissipative saturation pdtrans =/= constant -! - if (do_dtrans) then - do k=kph, krefj - tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) - drlee(k) = -tau_src(k)/rho(k) * pdtrans - enddo - endif - - - ENDIF !taulee > 0.0 - - - endif !strver -! - -!========================================================================= - if (strver == 'gfs_2018' .or. strver == 'kd_2005') then -!========================================================================= -! -! orowaves: OGW+DSW/Lee -! - efact = (oa + 2.0) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + clx) ** (oa+1.) - - kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx - kxlinv = coefm * cleff - tem = fr * fr * oc - gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 -!========================================================================= -! source fluxes: taulin, taufrb -!========================================================================= - tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact - - coef_h2 = kxlinv *rhohm * bnv*umag - taulin = coef_h2 *hamp*hamp - hcrit = fcrit_gfs*umag/bnv - tauhcr = coef_h2 *hcrit*hcrit - - IF (fr <= fcrit_gfs) then - tauogw = taulin - tautot = taulin - taulee = 0. - drlee(:) = 0. - ELSE !fr > fcrit_gfs - tauogw = tauhcr - taulee = max(tautot - tauogw, 0.0) - if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) -! approximate drlee(k) between [izb, klwb] -! find klwb and decrease taulee(izb) => taulee(klwb) = 0. -! above izb tau - if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then - - mkz = sqrt(mkz2) - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) - phmkz(:) = 0.0 - klwb = max(izb, 1) - kotr = levs+1 - phmkz(kph-1) = fr ! initial Phase of the Lee-OGW - - loop_lwb_gfs18: do k=kph, levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, velmin*velmin) - mkz2 = bn2i(k)/umd2 - kx2 - if ( mkz2 > mkz2min ) then - mkz = sqrt(mkz2) - frlocal = max(hdsw*bvi(k)/umd(k), frlwb) - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k - else - kotr = k - exit loop_lwb_gfs18 - endif - enddo loop_lwb_gfs18 -! -! - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 - ENDIF !fr > fcrit_gfs - - - ENDIF !strbase='gfs2017' .or. strbase='kd_2005' - - -! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge -! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' -! - end subroutine ugwp_taub_oro -! -!-------------------------------------- -! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, & -! con_pi, con_g, kxw, fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, & -! pmid1, pint1, xn, yn, umag, drtau, kdis_oro) - - subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - pi, grav, kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, xn, yn, umag, drtau, kdis) - - use ugwp_common_v1, only : dw2min, velmin - use cires_ugwp_module_v1, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module_v1, only : kvg, ktg, krad, kion - use ugwp_oro_init_v1, only : coro , fcrit_sm , fcrit_sm2 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - real , dimension(levs+1) :: tau_src - - real, intent(in) :: pi, grav - - real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm - real, dimension(levs+1), intent(in) :: zpi, pmid, pint - real , intent(in) :: xn, yn, umag - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: bnv2min, pi2, rgrav - real :: uref, udir, uf2, ufd, uf2p - real, dimension(levs+1) :: tauz - real, dimension(levs) :: rho - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, kcrit, kref - real :: kx2, kx2w, kxs - real :: mkzm, mkz, dkz, mkz2, ch, kzw3 - real :: wfdM, wfdT, wfiM, wfiT - real :: fdis, mkzi, keff_m, keff_t - real :: betadis, betam, betat, cdfm, cdft - real :: fsat, hsat, hsat2, kds , c2f2 - - pi2 = 2.0*pi - bnv2min = (pi2/1800.)*(pi2/1800.) - rgrav = 1.0/grav - - drtau(1:levs) = 0.0 - kdis (1:levs) = 0.0 - - ch = coro - - kx2w = kxw*kxw - kx2 = kxridge*kxridge - if( kx2 < kx2w ) kx2 = kx2w - kxs = sqrt(kx2) - c2f2 = fcor*fcor/kx2 -! -! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) -! -! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -!=============================================================================== -! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 -! rotational/non-hyrostatic effects are important only for high-res runs -! Udir = 0, Udir < 0 are not -! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz -! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) -! stochastic "tauogw'-setup+ sigma_tau ; -! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves -! target is to get "multiple"-saturation levels for OGWs -!=============================================================================== - tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode - ! sign of tauz > 0...and its attenuate with Z - k = krefj - uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves - uf2 = uref*uref - c2f2 - if (uf2 > 0) then - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2.gt.0) then - mkzm = sqrt(mkz2) - else - return ! wave reflection mkz2 <=0. - endif - else - return ! wave absorption uf2 <= 0. - endif -! -! upward solver for single "mode" with tauz(levs+1) =0. at the top -! - kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer - kcrit = levs - do k= krefj+1, levs -! -! 2D-wave propagation along reference-wind direction -! udir = 0 critical wind for coro =0 -! cdop = -uref .... upwind waves travel against MF -! - udir = ui(k)*xn +vi(k)*yn - uf2 = udir*udir - c2f2 - - - if (uf2 < dw2min .or. udir <= 0.0) then - kcrit =K - tauz(kcrit:levs) = 0. - exit ! vert-level loop - endif -! -! wave-based solution -! - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2 > 0) then - mkzm = sqrt(mkz2) -! -! do dissipative flux vs saturation: kvg, ktg, krad, kion -! - kzw3 = mkzm*mkz2 -! - keff_m = kvg(k)*mkz2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*mkz2 + krad(k) -! -! - uf2p = uf2 + 2.0*c2f2 - betadis = uf2/uf2p - betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw - betaT = 1.0- BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*mkz2 + keff_m - wfiT = kds*mkz2 + keff_t -! - cdfm = sqrt(uf2)*kxs - cdft = abs(udir)*kxs - wfdM = wfiM/cdfm *BetaM - wfdT = wfiT/Cdft *BetaT - mkzi = 2.0*mkzm*(wfdM+wfdT) - - fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) - tauz(k) = fdis - hsat2 = fcrit_sm2 * uf2 *bn2i(k) - fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) - if (fdis > fsat) then - tauz(k) = min(fsat, tauz(k-1)) -!================================================================= -! two definitions for eddy mixing of MF: -! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 -! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 -!================================================================= - kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) - kdis(k) = kds - endif - else - tauz(k:levs) = 0. ! wave is reflected above - kds = 0. - endif - enddo - - do k=krefj+1, kcrit - drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) - enddo -! -! - end subroutine ugwp_oro_lsatdis -! -! - subroutine ugwp_tofd(im, levs, con_cp, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none -! - integer :: im, levs - real(kind_phys) :: con_cp - real(kind_phys), dimension(im, levs) :: u, v, zmid - real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl - real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: rcpd2 - real :: sgh = 30. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 - rcpd2 = 0.5/con_cp -! - - do i=1, im - - zdec = max(n_tofd*sigflt(i), zpbl(i)) - zdec = min(ze_tofd, zdec) - rzdec = 1.0/zdec - sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) - - do k=1, levs - zmet = zmid(i,k) - if (zmet > ztop_tofd) cycle - ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) - umag = sqrt(ekin) - zarg = zmet*rzdec - zexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp - utofd(i,k) = -krf*u(i,k) - vtofd(i,k) = -krf*v(i,k) - epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re - krf_tofd(i,k) = krf - enddo - enddo -! - end subroutine ugwp_tofd -! -! - subroutine ugwp_tofd1d(levs, con_cp, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none - integer :: levs - real(kind_phys) :: con_cp - real(kind_phys), dimension(levs) :: u, v, zmid - real(kind_phys) :: sigflt, elvmax, zpbl, zsurf - real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: rcpd2 - real :: sghmax = 5. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 - rcpd2 = 0.5/con_cp -! - zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl - zdec = min(ze_tofd, zdec) ! cannot exceed 18 km - rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - - do k=1, levs - zmet = zmid(k)-zsurf - if (zmet > ztop_tofd) cycle - ekin = u(k)*u(k) + v(k)*v(k) - umag = sqrt(ekin) - zarg = zmet*rzdec - ztexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp - - utofd(k) = -krf*u(k) - vtofd(k) = -krf*v(k) - epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re; epstofd(k) can be skipped - krf_tofd(k) = krf - enddo -! - end subroutine ugwp_tofd1d - - -end module cires_vert_orodis_v1 diff --git a/physics/cires_vert_wmsdis.F90 b/physics/cires_vert_wmsdis.F90 deleted file mode 100644 index 9e0bbf37c..000000000 --- a/physics/cires_vert_wmsdis.F90 +++ /dev/null @@ -1,425 +0,0 @@ - subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! -! use para_taub, only : tau_ex - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs - integer :: nw, naz ! # - waves for each azimuth (naz) - integer :: ksrc ! source level - real :: kxw ! horizontal wn - real :: taub_lat ! lat-dep tau_bulk N/m2 -! - real, dimension(nw) :: ch, dch, taub_spect - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - real, dimension(levs+1 ) :: uaz - - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - - real, dimension(levs+1 ) :: taux, tauy, bnrho - real, dimension(levs ) :: dzirho , dzpi - -! - integer :: iaz, k , inc - real, parameter :: gcstar=1.0 - integer , parameter :: nslope=1 - real :: spnorm ! source level normalization factor for the Broad Spectra - real :: bnrhos ! sum(taub_spect*dc) = spnorm taub_sect_norm = taub_spect/spnorm -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - bnrhos = bvi(ksrc)/rhoi(ksrc) - do k=1,levs - dzpi(k) = zint(k+1)-zint(k) - dzirho(k) = 1.0 / (rho(k)*dzpi(k)) ! grav/abs(dp(k)) still hydrostatic "ugwp" - bnrho(k) = (rhoi(k)/bvi(k)) !*bnrhos * gcstar ! gcstar=1.0 and bnrho(k=ksrc) =1. - enddo - k = levs+1 - bnrho(k) = (rhoi(k)/bvi(k))*bnrhos -! -! re-define ch, dch, taub_spect, this portion can be moved to "ugwp_init" -! -! -! - call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) - - -! print *, ' after FVS93_ugwp ', nw, maxval(ch), minval(ch) -! -! do normaalization for the spectral element of the saturated flux -! - bnrho = bnrho *spnorm - -! print * -! do inc=1, nw -! write(6,221) inc, ch(INC),taub_lat*taub_spect(inc), spnorm, dch(inc) -!221 FORMAT( i6, 2x, F8.2, 3(2x, E10.3)) -! enddo -! pause - - loop_iaz: do iaz =1, naz - - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) - enddo -! -! -! multi-wave broad spectrum of FVS-93 with ~scheme of WMS-IFS 2010 -! -! print *, ' iaz before ugwp_wmsdis_az1 ', iaz -! - - call ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_spect, taub_lat, & - spnorm, fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, bnrho, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - -! print *, ' iaz after ugwp_wmsdis_az1 ', iaz - -! - enddo loop_iaz ! azimuth of gw propagation directions -! -! sum over azimuth and project atau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum( kedd(k,:)) - enddo -! - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) - -! end solver: gw_azimuth_solver_ls81 -! sign ax in rho*du/dt = -d(rho*tau)/dz -! [(k) - (k+1)] -! du/dt = ax = -1/rho*d( tau) /dz -! - ax =0. ; ay = 0. - - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - - return - end subroutine ugwp_wmsdis_naz - - -! ======================================================================= - subroutine ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_sp, tau_bulk, & - spnorm, fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, bnrho, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) -! -! use para_taub, only : tau_ex, xlatdeg !for exchange src-tau -! - use cires_ugwp_module, only : f_coriol, f_nonhyd, f_kds, linsat - use cires_ugwp_module, only : ipr_ktgw, ipr_spgw, ipr_turb, ipr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! ======================================================================= - integer :: levs, ksrc, nw - real :: fcor, c2f2, kxw -! - real, dimension(nw) :: taub_sp, ch, dch - real :: tau_bulk, spnorm - real, dimension(levs) :: zm, rho, dzirho, dzpi - real, dimension(levs+1) :: zi, um, tm, bn2, bn, rhoi, bnrho - real, dimension(levs+1) :: kvg, ktg, krad, kion, kmol - real, dimension(levs+1) :: ked, tau - real, dimension(levs ) :: eps -! -!locals - integer :: k, inc - real, dimension(levs+1) :: umi - real :: zcin, zci_min, ztmp, zcinc - real :: zcimin=0.5 ! crit-level precision, 0.5 and start of Ch_MIN - real, parameter :: Keff = 0.2 - - real, dimension(nw) :: zflux ! - real, dimension(nw) :: wzact, zacc ! =1 ..crit level change it - - real, dimension(levs) :: zcrt ! - real, dimension(nw, levs) :: zflux_z, zact - - real :: zdelp, kxw2 - real :: vu_eff, vu_lin, v_kzw, v_cdp, v_wdp, v_kzi - real :: dfsat, fdis, fsat, fmode, expdis - real :: vc_zflx_mode, vm_zflx_mode - real :: tau_g5 -! ======================================================================= -!eps, ked, tau - - eps (:) =0; ked = 0.0 ; - kxw2 = kxw*kxw -! - zcrt(1:levs) = 0.0 - umi(1:levs+1) = um -! umi(1:levs+1) = um(1:levs+1) -um(ksrc) - - zci_min = zcimin - -! CALL slat_geos5(1, xlatdeg(1), tau_g5) -! tau_bulk = tau_g5 !tau_bulk*0.75 !3.75e-2 -! - zflux(:) = taub_sp(:)*tau_bulk ! includes tau_bulk(x,y) and spectral normalization - - zflux_z(1:nw,ksrc)=zflux(:) - - tau(1:levs+1) = tau_bulk ! constant flux for all layers k0.0 ) then -! ztmp = sum( ch(:)*zacc(:)*zflux(:)*dch(:) ) -! zcrt(k)=ztmp/tau(k) -! else -! zcrt( k )=zcrt(k-1) -! endif -! --------------------------------------------------------- -! do saturation (eq. (26) and (27) of scinocca 2003) -! + add molecular/eddy dissipation od gw-spectra vay-2015 -! for each mode & direction -! x by exp(-mi*zdelp) x introduce ....... mi(nw) -! -! mode-loop + add molecular/eddy dissipation od gw-spectra vay-2015 -! - do inc=1,nw - if (zact(inc,k) == 0.0) then - zflux(inc) = 0.0 - zflux_z(inc,k) = zflux(inc) - else - vu_eff = kvg(k) ! + ktg (k) !* ipr_ktgw - vu_lin = kion(k) ! + krad(k) !* ipr_ktgw - vu_eff = 2.e-5*exp(zi(k)/7000.)+.01 - zcin= ch(inc) - -!======================================================================= -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= - v_cdp = zcin-umi(k) - v_wdp = kxw*v_cdp - if (v_wdp.gt.0) then - v_kzw = bn(k)/v_cdp !can be non-hydrostatic - v_kzi = abs(( v_kzw*v_kzw*vu_eff + vu_lin) /v_wdp*v_kzw) - expdis = exp(-2.*v_kzi*dzpi(k) ) - else - v_kzi = 0. - expdis = 1.0 - endif - fmode = zflux(inc) - fdis = fmode*expdis ! only dissipation/crit_lev degrades it -!------------------------ -! includes rho/bn /(rhos/bns) *spnorm -!------------------------ - fsat = bnrho(k)* v_cdp*v_cdp /zcin ! expression for saturated flux - ! zfluxs=gcstar*zfct( k)*(zcin-zui( k ))**2/zcin -! flux_tot - sat.flux -! - dfsat= fdis-fsat - if( dfsat > 0.0 ) then -! put sat-n limit - zflux(inc) = fsat - else -! assign dis-ve flux - zflux(inc) =fdis - endif - zflux_z(inc,k)=zflux(inc) - - if (zflux_z(inc,k) > zflux_z(inc,k-1) ) zflux_z(inc,k) = zflux_z(inc,k-1) - - endif - - enddo -! -! integrate over spectral modes zpu(y, z, azimuth) zact( inc, )*zflux( inc, )*[d("zcinc")] -! - tau(k) = sum( zflux_z(:,k)*dch(:)) -!------------------------------------------------------------------------------ -! define expressions for eps-heat + Ked, needs more work for the broad spectra -! formulation especially for Ked -! after defining Ked .....GW-eddy cooling needs to be added -! for now "only" heating here -!============================================================================== - eps(k) =0. - do inc=1, nw - if (zact(inc,k) == 0.0) cycle ! dc-integration + dtau/dz - vc_zflx_mode = zflux(inc) - - zdelp= abs(ch(inc)-umi(k)) * dch(inc) /dzpi(k) - vm_zflx_mode=zflux_z(inc,k-1) - eps(k) =eps( k ) + (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - - - enddo !inc=1, nw - ked(k) = Keff*eps(k)/bn2(k) -! -! -------------- -! - enddo ! end k do-loop vertical loop do k=ksrc+1, levs - -!top lid - k =levs+1 - ked(k) = ked(k-1) -! eps(k) = eps(k-1) - tau(k) =tau(k-1)*0.933 - -! from surface to ksrc-1 -! tau(1:ksrc) = tau(ksrc) - ked(1:ksrc) = 0. - eps( 1:ksrc) = 0. - -! -! output: eps, ked, tau for given azimuth -! - end subroutine ugwp_wmsdis_az1 -! -! - subroutine FVS93_ugwps(nw, ch, dch, taub_sp, spnorm, nslope, bn2, bn, bnrhos) - implicit none - integer :: nw, nslope - real :: bn2, bn, bnrhos -!! real :: taub_lat ! bulk - lat-dep momentum flux - real, dimension (nw) :: ch, dch, taub_sp -! locals - integer :: i, inc - real, parameter :: zcimin = 0.5, zcimax = 95.0, zgam =1./4. - real, parameter :: zms = 6.28e-3/2. ! mstar Lz ~ 2km - real :: zxran, zxmax, zxmin, zx1, zx2, zdx, ztx, rch - real :: bn3, bn4, zcin, tn4, tn3, tn2, cstar - real :: spnorm ! needs to be passed for saturation flux norm-n - real :: tau_bulk -!-------------------------------------------------------------------- -! -! transforms ch -uniform => 1/ch and back to non-uniform ch, dch -! -!------------------------------------------------------------------- -! note that this is expresed in terms of the intrinsic ch or vertical wn=N/cd -! at launch cd=ch-um(ksrc), the transformation is identical for all -! levels, azimuths and horizontal pixels -! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform -! - zxmax=1.0 /zcimin - zxmin=1.0 /zcimax - zxran=zxmax-zxmin - zdx=zxran/float(nw-1) ! d_kz or d_mi -! -! - zx1=zxran/(exp(zxran/zgam)-1.0 ) !zgam =1./4. - zx2=zxmin-zx1 -! -! add idl computations for zci =1/zx -! x = 1/c stretching transform to look at final ch(i), dch(i) -! - - do i=1, nw - ztx=float(i-1)*zdx+zxmin - rch=zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 - ch(i)=1.0 /rch !eq. 28 of scinocca 2003 - dch(i)=ch(i)*ch(i)*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 - enddo -! -! nslope-dependent flux taub_spect(nw) momentum flux spectral density -! need to check math....expressions -! eq. (25) of scinocca 2003 with u-uo=0 it is identical to all azimuths -! -! - cstar=bn/zms - bn4=bn2*bn2 ! four times - bn3=bn2*bn - if(nslope==1) then -! s=1 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc) =bnrhos * zcin*bn4/(bn4+tn4) - enddo -! - elseif(nslope==2) then -! s=2 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc)= bnrhos*zcin*bn4/(bn4+tn4*zcin/cstar) - enddo -! - elseif(nslope==-1) then -! s=-1 case - do inc=1, nw - zcin=ch(inc) - tn2=(zms*zcin)**2 - taub_sp(inc)=bnrhos*zcin*bn2/(bn2+tn2) - enddo -! s=0 case - elseif(nslope==0) then - - do inc=1, nw - zcin=ch(inc) - tn3=(zms*zcin)**3 - taub_sp(inc)=bnrhos*zcin*bn3/(bn3+tn3) - enddo - endif ! for n-slopes -!============================================= -! normalize launch momentum flux -! ------------------------------------ -! (rho x f^h = rho_o x f_p^total) integrate (zflux x dx) - - tau_bulk= sum(taub_sp(:)*dch(:)) - spnorm= 1./tau_bulk - - do inc=1, nw - taub_sp(inc)=spnorm*taub_sp(inc) - enddo - - end subroutine FVS93_ugwps - diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index fa5b317fc..3035a2c95 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -274,7 +274,7 @@ intent = inout optional = F [dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -283,7 +283,7 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -292,7 +292,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -301,7 +301,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -310,7 +310,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -319,7 +319,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -328,7 +328,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -337,7 +337,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -364,72 +364,72 @@ intent = out optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -592,7 +592,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -600,7 +600,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -608,7 +608,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index c47079992..abb78e7a6 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,266 +1,3 @@ -! - module sso_coorde -! -! specific to COORDE-2019 project OGW switches/sensitivity -! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) -! pgd4=4 (4 timse taub, control pgwd=1) -! - use machine, only: kind_phys - real(kind=kind_phys),parameter :: pgwd = 1.0_kind_phys - real(kind=kind_phys),parameter :: pgwd4 = 1.0_kind_phys - logical, parameter :: debugprint = .false. - end module sso_coorde -! -! -! Routine cires_ugwp_driver_v0 is replaced with cires_ugwp.F90/cires_ugwp_run in CCPP -#if 0 - subroutine cires_ugwp_driver_v0(me, master, - & im, levs, nmtvr, dtp, kdt, imx, do_ugwp, do_tofd, - & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, - & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, - & phii, phil, del, hprime, oc, oa4, clx, theta, - & gamm, sigma, elvmax, sgh30, kpbl, - & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, - & tau_tofd, tau_mtb, tau_ogw, tau_ngw, - & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, - & rain, ntke, tke, lprnt, ipr) -!----------------------------------------------------------- -! Part 1 "old-revised" gfs-gwdps_v0 or "old" gwdps (if do_ugwp=.false.) -! Part 2 non-stationary multi-wave GWs FV3GFS-v0 -! Part 3 Dissipative version of UGWP-tendency application -! (similar to WAM-2017) -!----------------------------------------------------------- - use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv, & - con_omega - - use ugwp_wmsdis_init, only : tamp_mpa, ilaunch - use sso_coorde, only : pgwd, pgwd4, debugprint - implicit none -!input - - integer, parameter :: kp = kind_phys - - integer, intent(in) :: me, master - integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr - - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) - logical :: do_ugwp, do_tofd, lprnt - integer, intent(in) :: kpbl(im) - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd - &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area - &, rain - - real(kind=kind_phys), intent(in), dimension(im,levs) :: - &, ugrs, vgrs, tgrs, qgrs, prsl, prslk, phil, del - real(kind=kind_phys), intent(in), dimension(im,levs+1) :: - & phii, prsi - -! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) - real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc - &, theta, gamm, sigma, elvmax - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4, clx - real(kind=kind_phys), intent(in) :: tke(im,levs) -!out - real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt - &, gw_dTdt, gw_kdis - -!-----locals + diagnostics output - - real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt - &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt - - real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg - - real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, - & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw, turb_fac - real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw - &, du3dt_tms - real(kind=kind_phys), dimension(im) :: tem - -! locals - real(kind=kind_phys) :: rfac, tx1 - integer :: i, j, k, ix -! -! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax -! -! real(kind=kind_phys), dimension(im) :: hprime, -! & oc, theta, sigma, gamm, elvmax -! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 -! -! switches that activate impact of OGWs and NGWs along with eddy diffusion -! - real(kind=kind_phys), parameter :: pogw=1.0_kp, pngw=1.0_kp - &, pked=1.0_kp, zero=0.0_kp - &, ompked=1.0_kp-pked -! -! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS execute ugwp_driver_v0 ' -! write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr - write(6,*) ' COORDE EXPER pogw = ' , pogw - write(6,*) ' COORDE EXPER pgwd = ' , pgwd - write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 - print * - endif - - do i=1,im - zlwb(i) = zero - enddo -! -! 1) ORO stationary GWs -! ------------------ - - if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag - CALL GWDPS_V0(IM, levs, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, - & ugrs , vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, - & prslk, phii, phil, DTP,KDT, - & sgh30, HPRIME, OC, OA4, CLX, THETA, - & SIGMA, GAMM, ELVMAX, - & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, - & cdmbgwd(1:2), me, master, rdxzb, - & con_g, con_omega, - & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, - & du3dt_mtb, du3dt_ogw, du3dt_tms) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' - print * - endif - else ! calling old GFS gravity wave drag as is - do k=1,levs - do i=1,im - pdvdt(i,k) = zero - pdudt(i,k) = zero - pdtdt(i,k) = zero - pkdis(i,k) = zero - enddo - enddo - if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero) then - call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & - &, ugrs, vgrs, tgrs, qgrs & - &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& - &, hprime, oc, oa4, clx, theta, sigma, gamm & - &, elvmax, dusfcg, dvsfcg & - &, con_g, con_cp, con_rd, con_rv, imx & - &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) - endif - - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - endif -! - if (cdmbgwd(3) > zero) then -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) - -! call slat_geos5(im, xlatd, tau_ngw) -! - if (abs(1.0_kp-cdmbgwd(3)) > 1.0e-6_kp) then - if (cdmbgwd(4) > zero) then - do i=1,im - turb_fac(i) = zero - tem(i) = zero - enddo - if (ntke > 0) then - do k=1,(levs+levs)/3 - do i=1,im - turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) - tem(i) = tem(i) + del(i,k) - enddo - enddo - do i=1,im - turb_fac(i) = turb_fac(i) / tem(i) - enddo - endif - rfac = 86400000 / dtp - do i=1,im - tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1_kp, min(5.0_kp, tx1)) - enddo - endif - do i=1,im - tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) - enddo - endif -! - call fv3_ugwp_solv2_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, prsl, prsi, - & phil, xlatd, sinlat, coslat, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - endif - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - gw_dtdt(i,k) = Pdtdt(i,k) - gw_dudt(i,k) = Pdudt(i,k) - gw_dvdt(i,k) = Pdvdt(i,k) - gw_kdis(i,k) = Pkdis(i,k) - enddo - enddo - endif - - if (pogw == zero) then -! zmtb = 0.; zogw =0. - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - endif - - return - -!============================================================================= -! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving -! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" -!============================================================================= -! -! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies -!------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = zero ; ed_dvdt(i,k) = zero ; ed_dtdt(i,k) = zero - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, del, - & prsl, prsi, phil, prslk, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) - - do k=1,levs - do i=1,im - gw_dtdt(i,k) = gw_dtdt(i,k)*ompked + ed_dtdt(i,k)*pked - gw_dvdt(i,k) = gw_dvdt(i,k)*ompked + ed_dvdt(i,k)*pked - gw_dudt(i,k) = gw_dudt(i,k)*ompked + ed_dudt(i,k)*pked - enddo - enddo - - end subroutine cires_ugwp_driver_v0 -#endif ! !===================================================================== ! @@ -301,12 +38,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, !---------------------------------------- USE MACHINE , ONLY : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + use ugwp_common_v0,only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 &, pi, rad_to_deg, deg_to_rad, pi2 &, rdi, gor, grcp, gocp, fv, gr2 &, bnv2min, dw2min, velmin, arad - use ugwp_oro_init, only : rimin, ric, efmin, efmax + use ugwpv0_oro_init, only : rimin, ric, efmin, efmax &, hpmax, hpmin, sigfaci => sigfac &, dpmin, minwnd, hminmt, hncrit &, RLOLEV, GMAX, VELEPS, FACTOP @@ -315,11 +52,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, &, cdmb, cleff, fcrit_gfs, fcrit_mtb &, n_tofd, ze_tofd, ztop_tofd - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - use sso_coorde, only : pgwd, pgwd4, debugprint + use cires_ugwpv0_module, only : kxw, max_kdis, max_axyz + !---------------------------------------- implicit none - integer, parameter :: kp = kind_phys + integer, parameter :: kp = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -452,22 +189,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! sigmin = 2.*hpmin/dsmax !dxres ! Moorthi - this will not reproduce sigmin = 2.*hpmin/dxres !dxres -! if (kdt == 1) then -! print *, sgrmax, sgrmin , ' min-max sparea ' -! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax -! print *, 'dxres/dsmax ', dxres, dsmax -! print *, ' shilmin gammin ', shilmin, gammin -! endif - kxridge = float(IMX)/arad * cdmbgwd(2) - if (me == master .and. kdt == 1 .and. debugprint) then - print *, ' gwdps_v0 kxridge ', kxridge - print *, ' gwdps_v0 scale2 ', cdmbgwd(2) - print *, ' gwdps_v0 IMX ', imx - print *, ' gwdps_v0 GAM_MIN ', gammin - print *, ' gwdps_v0 SSO_MIN ', sso_min - endif + kxridge = float(IMX)/arad * cdmbgwd(2) do i=1,im idxzb(i) = 0 @@ -543,9 +267,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, endif enddo - IF (npt == 0 .and. debugprint) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin + IF (npt == 0) then RETURN ! No gwd/mb calculation done endif @@ -918,16 +640,16 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, kxridge = 1.0 / sqrt(sparea(J)) XLINV(I) = XLINGFS !or max(kxridge, inv_b2eff) ! 6.28/Lx ..0.5*sigma(j)/heff = 1./Lridge taulin(i) = 0.5*ROLL(I)*XLINV(I)*BNV*ULOW(I)* - & heff*heff*pgwd4 + & heff*heff if ( FR > fcrit_gfs ) then TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 ! nonlinear FLUX Tau0...XLINV(I) + & * ULOW(I) * GFOBNV * EFACT ! nonlinear FLUX Tau0...XLINV(I) ! else ! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 + & * ULOW(I) * GFOBNV * EFACT ! ! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs ! @@ -1083,9 +805,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! --------------------------- IF( do_tofd ) then axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0 .and. debugprint) then - print *, 'VAY do_tofd from surface to ', ztop_tofd - endif + + DO I = 1,npt J = ipt(i) zpbl =rgrav*phil( j, kpbl(j) ) @@ -1099,8 +820,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, vp1(k) = v1(j,k) enddo - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, - & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + call ugwpv0_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, + & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) do k=1,km axtms(j,k) = utofd1(k) @@ -1151,8 +872,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! OGW-s above blocking height ! TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) * pgwd - DTAUY = TAUD(I,K) * YN(I) * pgwd + DTAUX = TAUD(I,K) * XN(I) + DTAUY = TAUD(I,K) * YN(I) Pdvdt(j,k) = DTAUY +Pdvdt(j,k) Pdudt(j,k) = DTAUX +Pdudt(j,k) @@ -1185,97 +906,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, RETURN - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0 .and. debugprint) then - print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' -! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' - print *, maxval(pdTdt)*86400., minval(pdTdt)*86400,'vgw_epsoro' - print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' - print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' -! print *, maxval(tau_tofd), ' tau_tofd ' -! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' -! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' - if (maxval(abs(pdudt))*86400. > 100.) then - - print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' - print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' - print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' - print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' - print *, maxval(del), minval(del), ' del gwdps-v0 ' - print *, maxval(phil)*rgrav,minval(phil)*rgrav, 'zmet' - print *, maxval(phii)*rgrav,minval(phii)*rgrav, 'zmeti' - print *, maxval(prsi), minval(prsi), ' prsi ' - print *, maxval(prsL), minval(prsL), ' prsL ' - print *, maxval(RO), minval(RO), ' RO-dens ' - print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' BNV2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' - print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' - print * - do i =1, npt - j= ipt(i) - print *,zogw(J)/hprime(j), zmtb(j)/hprime(j), - & phil(j,1)/9.81, nint(hprime(j)/sigma(j)) -! -!.................................................................... -! -! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m -! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km -! we must exclude blocking by small ridges -! VAY-kref < iblk zogw-lev 15 block-level: 39 -! -! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters -! MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) -! MAX(DW2,DW2MIN) * RDZ * RDZ -! ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) -! TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.1) -! TEMV = 1.0 / max(VELCO(I,K), 0.01) -! & * max(VELCO(I,K),0.01) -!.................................................................... - enddo - print * - stop - endif - endif - -! - RETURN -!--------------------------------------------------------------- -! review of OLD-GFS code 2017/18 most substantial changes -! a) kref > idxzb if idxzb > KPBL "OK" clipped-hill for OGW -! b) tofd -sgh30 "OK" -! -! c) FR < Frc linear theory for taub-specification -! -! d) solver of Palmer et al. (1987) => Linsat of McFarlane -! -!--------------------------------------------------------------- end subroutine gwdps_v0 !=============================================================================== -! use fv3gfs-v0 -! first beta version of ugwp for fv3gfs-128 -! cires/swpc - jan 2018 -! non-tested wam ugwp-solvers in fv3gfs: "lsatdis", "dspdis", "ado99dis" -! they reqiure extra-work to put them in with intializtion and namelists -! next will be lsatdis for both fv3wam & fv3gfs-128l implementations -! with (a) stochastic-deterministic propagation solvers for wave packets/spectra -! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) -! (c) guidance from high-res runs for GW sources and res-aware tune-ups -!23456 -! -! call gwdrag_wam(1, im, ix, km, ksrc, dtp, -! & xlat, gw_dudt, gw_dvdt, taux, tauy) -! call fv3_ugwp_wms17(kid1, im, ix, km, ksrc_ifs, dtp, -! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, -! & taux,tauy,grav, amol_i, me, lstep_first ) -! -! !23456============================================================================== !>\ingroup cires_ugwp_run @@ -1297,21 +932,19 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv + use ugwp_common_v0 , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv &, rad_to_deg, deg_to_rad &, rdi, gor, grcp, gocp &, bnv2min, dw2min, velmin, gr2 ! - use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec + use ugwpv0_wmsdis_init, only : hpscale, rhp2, bv2min, gssec &, v_kxw, v_kxw2, tamp_mpa, zfluxglob &, maxdudt, gw_eff, dked_min &, nslope, ilaunch, zmsi &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang - &, nwav, nazd, zcimin, zcimax - - use sso_coorde, only : debugprint + &, nwav, nazd, zcimin, zcimax ! implicit none !23456 @@ -1426,26 +1059,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, phil(j,k) = philg(j,k) * rgrav enddo enddo -!----------------------------------------------------------- -! also other options to alter tropical values -! tamp = 100.e-3*1.e3 = 100 mpa -! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 -!----------------------------------------------------------- -! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) - -! phil = philg*rgrav - -! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] -! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp - - if (kdt ==1 .and. mpi_id == master .and. debugprint) then - print *, maxval(tm1), minval(tm1), 'vgw: temp-res ' - print *, 'ugwp-v0: zcimin=' , zcimin - print *, 'ugwp-v0: zcimax=' , zcimax - print * - endif -! !================================================= do iazi=1, nazd do jk=1,klev @@ -1589,7 +1203,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo - endif ! for slopes + endif ! for slopes ! ! normalize momentum flux at the src-level ! ------------------------------ @@ -1866,257 +1480,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! !--------------------------------------------------------------------------- -! - if (kdt == 1 .and. mpi_id == master .and. debugprint) then - print *, 'vgw done ' -! - print *, maxval(pdudt)*86400, minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400, minval(pdvdt)*86400, 'vgw ay' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400, minval(pdtdt)*86400,'vgw eps' -! -! print *, ' ugwp -heating rates ' - endif - return end subroutine fv3_ugwp_solv2_v0 -!------------------------------------------------------------------------------- -! -! Part-3 of UGWP-V01 Dissipative (eddy) effects of UGWP it will be activated -! after tests of OGW (new revision) and NGW with MERRA-2 forcing. -! -!------------------------------------------------------------------------------- - subroutine edmix_ugwp_v0(im, levs, dtp, - & t1, u1, v1, q1, del, - & prsl, prsi, phil, prslk, - & pdudt, pdvdt, pdTdt, pkdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) -! - use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rdi, fv -! &, pi, rad_to_deg, deg_to_rad, pi2 - &, bnv2min, velmin, arad - - implicit none - - integer, intent(in) :: me, master, kdt - integer, intent(in) :: im, levs - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in), dimension(im,levs) :: - & u1, v1, t1, q1, del, prsl, prslk, phil -! - real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi - real(kind=kind_phys),dimension(im,levs) :: pdudt, pdvdt, pdTdt - real(kind=kind_phys),dimension(im,levs) :: pkdis -! -! out -! - real(kind=kind_phys),dimension(im,levs) :: ed_dudt, ed_dvdt - real(kind=kind_phys),dimension(im,levs) :: ed_dTdt -! -! locals -! - integer :: i, j, k -!------------------------------------------------------------------------ -! solving 1D-vertical eddy diffusion to "smooth" -! GW-related tendencies: du/dt, dv/dt, d(PT)/dt -! we need to use sum of molecular + eddy terms including turb-part -! of PBL extended to the model top, because "phys-tend" dx/dt -! should be smoothed as "entire" fields therefore one should -! first estimate and collect "effective" diffusion and applied -! it to each part of tendency or "sum of tendencies + Xdyn" -! this "diffusive-way" is tested with UGWP-tendencies -! forced by various wave sources. X' =dx/dt *dt -! d(X + X')/dt = K*diff(X + X') => -! -! wave1 dX'/dt = Kw * diff(X')... eddy part "Kwave" on wave-part -! turb2 dX/dt = Kturb * diff(X) ... resolved scale mixing "Kturb" like PBL -! we may assume "zero-GW"-tendency at the top lid and "zero" flux -! or "vertical gradient" near the surface -! -! 1-st trial w/o PBL interactions: add dU, dV dT tendencies -! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " -! ed_X = X_ed - X => final eddy tendencies -!--------------------------------------------------------------------------- -! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) -! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp -! - real(kind=kind_phys) :: Sw(levs), Sw1(levs), Fw(levs), Fw1(levs) - real(kind=kind_phys) :: Km(levs), Kpt(levs), Pt(levs), Ptmap(levs) - real(kind=kind_phys) :: rho(levs), rdp(levs), rdpm(levs-1) - real(kind=kind_phys),dimension(levs) :: ktur, vumol, up, vp, tp - real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum - real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis - real(kind=kind_phys) :: rdz , uz, vz, ptz -! ------------------------------------------------------------------------- -! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt -! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) -! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit -! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 -! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 -! - real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 - real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb - real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb - real(kind=kind_phys), parameter :: ric =0.25 - real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 - real(kind=kind_phys), parameter :: prmax = 4.0 - real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps - real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. - - - real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur - integer :: nstab - real(kind=kind_phys) :: w1, w2, w3 - rdtp = 1./dtp - nstab = 1 - stab_dt = 0.9999 - - do i =1, im - - rdp(1:levs) = grav/del(i, 1:levs) - - up(1:levs) = u1(i,1:levs) +pdudt(i,1:levs)*dtp - vp(1:levs) = v1(i,1:levs) +pdvdt(i,1:levs)*dtp - tp(1:levs) = t1(i,1:levs) +pdTdt(i,1:levs)*dtp - Ptmap(1:levs) = (1.+fv*q1(i,1:levs))/prslk(i,1:levs) - rho(1:levs) = rdi*prsl(i, 1:levs)/tp(1:levs) - Pt(1:levs) = tp(1:levs)*Ptmap(1:levs) - - do k=1, levs-1 - rdpm(k) = grav/(prsl(i,k)-prsl(i,k+1)) - rdz = .5*rdpm(k)*(rho(k)+rho(k+1)) - uz = up(k+1)-up(k) - vz = vp(k+1)-vp(k) - ptz =2.*(pt(k+1)-pt(k))/(pt(k+1)+pt(k)) - shr2(k) = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - bn2(k) = grav*rdz*ptz - zmet = phil(j,k)*rgrav - zgrow = exp(zmet*h4) - if ( bn2(k) < 0. ) then -! -! adjust PT-profile to bn2(k) = bnv2min -- neutral atmosphere -! adapt "pdtdt = (Ptadj-Ptdyn)/Ptmap" -! -! print *,' UGWP-V0 unstab PT(z) via gwdTdt ', bn2(k), k - - rineg = bn2(k)/shr2(k) - bn2(k) = max(bn2(k), bnv2min) - kamp = sqrt(shr2(k))*sc2u *zgrow - ktur(k) =kamp* (1+8.*(-rineg)/(1+1.746*sqrt(-rineg))) - endif - ritur = max(bn2(k)/shr2(k), rimin) - if (ritur > 0. ) then - kamp = sqrt(shr2(k))*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur(k)= kamp * w1 * w1 - endif - vumol(k) = 2.e-5 *exp(zmet/hps) - ksum(k) =ktur(k)+Pkdis(i,k)+vumol(k) - ksum(k) = max(ksum(k), kedmin) - ksum(k) = min(ksum(k), kedmax) - stab = 2.*ksum(k)*rdz*rdz*dtp - if ( stab >= 1.0 ) then - stab_dt = max(stab_dt, stab) - endif - enddo - nstab = max(1, nint(stab_dt)+1) - dtstab = dtp / float(nstab) - ksum(levs) = ksum(levs-1) - Fw(1:levs) = pdudt(i, 1:levs) - Fw1(1:levs) = pdvdt(i, 1:levs) - Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) - - do j=1, nstab - call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, - & rdp, rdpm, Sw, Sw1) - Fw = Sw - Fw1 = Sw1 - enddo - - ed_dudt(i,:) = Sw - ed_dvdt(i,:) = Sw1 - - Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) - Kpt = Km*iPr_pt - Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) - do j=1, nstab - call diff_1d_ptend(levs, dtstab, Fw, Kpt, rdp, rdpm, Sw) - Fw = Sw - enddo - ed_dtdt(i,1:levs) = Sw(1:levs)/Ptmap(1:levs) - - enddo - - end subroutine edmix_ugwp_v0 - subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! S(:) = 0.0 ; S1(:) = 0.0 -! -! explicit diffusion solver -! - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. - cd - ad -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - S1(K) = F1(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) - enddo - k = levs - S(k) = F(k) - S1(k) = F1(k) - end subroutine diff_1d_wtend - - subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! -! explicit "eddy" smoother for tendencies -! - - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. -(cd +ad) -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - enddo - k = levs - S(k) = F(k) - end subroutine diff_1d_ptend + diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 new file mode 100644 index 000000000..00fd42dbd --- /dev/null +++ b/physics/ugwpv1_gsldrag.F90 @@ -0,0 +1,719 @@ +!> \file ugwpv1_gsldrag.F90 +!! This introduces two gravity wave drag schemes ugwpv1/CIRES and GSL/drag_suite.F90 under "ugwpv1_gsldrag" suite: +!! 1) The "V1 CIRES UGWP" scheme as tested in the FV3GFSv16-127L atmosphere model and workflow, which includes: +!! a) the orograhic gravity wave drag, flow blocking scheme and TOFD (Beljaars et al, 2004). +!! b) the v1 CIRE ugwp non-stationary GW scheme, new revision that generate realistic climate of FV3GFS-127L +!! in the strato-mesosphere in the multi-year simulations (Annual cycles, SAO and QBO in th tropical dynamics). +!! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: +!! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales +!! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) +!! b) small-scale gravity wave drag scheme -- active typically in stable PBL at horizontal grid resolutions down to ~1km +!! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) +!! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km +!! (Beljaars et al, 2004 \cite beljaars_et_al_2004) +!! See Valery Yudin's presentation at 2020 UFS User's meeting (Jul 2020): +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. +!! Unified Formalism: +!! 1. GW Sources: Stochastic and physics based mechanisms for GW-excitations in the lower atmosphere, calibrated by the high-res analyses/forecasts, and observations (3 types of GW sources: orography, convection, fronts/jets). +!! 2. GW Propagation: Unified solver for "propagation, dissipation and breaking" excited from all type of GW sources. +!! 3. GW Effects: Unified representation of GW impacts on the "resolved" flow for all sources (energy-balanced schemes for momentum, heat and mixing). +!! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf +!! +!! The ugwpv1_gsldrag scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! NA do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD is not active (NA) +!! NA do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale OGWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale OGWD +!! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag +!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only +!! do_ugwp_v1_w_gsldrag -- activates V1 CIRES UGWP scheme with orographic drag of GSL +!! Note that only one "large-scale" scheme can be activated at a time. +!! + +module ugwpv1_gsldrag + + use machine, only: kind_phys + + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 + + use drag_suite, only: drag_suite_run + + implicit none + + private + + public ugwpv1_gsldrag_init, ugwpv1_gsldrag_run, ugwpv1_gsldrag_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the unified UGWP +!> \section arg_table_ugwpv1_gsldrag_init Argument Table +!! \htmlinclude ugwpv1_gsldrag_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine ugwpv1_gsldrag_init ( & + me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & + con_pi, con_rerth, con_p0, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & + do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) + + use ugwp_common + +!---- initialization of unified_ugwp + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + character(len=*), intent (in) :: input_nml_file(:) + integer, intent (in) :: logunit + integer, intent(in) :: jdat(8) + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + real(kind=kind_phys), intent (in) :: ak(levs+1), bk(levs+1) + real(kind=kind_phys), intent (in) :: dtp + + real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt + logical, intent (in) :: do_ugwp + + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only,do_ugwp_v1_w_gsldrag + + character(len=*), intent (in) :: fn_nml2 + !character(len=*), parameter :: fn_nml='input.nml' + + integer :: ios + logical :: exists + real :: dxsg + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!============================================================================ +! +! gwd_opt => "1 and 2, 3, 22, 33' see previous GSL-commits +! related to GSL-oro drag suite +! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography +! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 +! FV3GFS_io.F90: if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & +! FV3GFS_io.F90: Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then +! FV3GFS_io.F90: if ( (Model%gwd_opt==3 .or. Model%gwd_opt==33) .or. & +! FV3GFS_io.F90: ( (Model%gwd_opt==2 .or. Model%gwd_opt==22) .and. & +! +! gwd_opt=1 -current 14-element GFS-EMC subgrid-oro input +! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input +! GSL uses the gwd_opt flag to control "extra" diagnostics (22 and 33) +! CCPP may use gwd_opt to determine 14 or 24 variables for the input +! but at present you work with "nmtvr" +! GFS_GWD_generic.F90: integer, intent(in) :: im, levs, nmtvr +!GFS_GWD_generic.F90: real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) +!GFS_GWD_generic.F90: if (nmtvr == 14) then ! gwd_opt=1 current operational - as of 2014 +!GFS_GWD_generic.F90: elseif (nmtvr == 10) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 6) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp gwd_opt=2,3 +! +! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 +! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp +!============================================================================== + ! Test to make sure that at most only one large-scale/blocking + ! orographic drag scheme is chosen + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & + do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & + do_ugwp_v1_orog_only)) .or. & + (do_gsl_drag_ls_bl.and.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: Only one large-scale& + &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& + &do_gsl_drag_ls_bl,do_ugwp_v1 or & + &do_ugwp_v1_orog_only) can be chosen" + errflg = 1 + return + + end if +! + if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then + print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 + print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only + write(errmsg,'(*(a))') " the CIRES CCPP-suite does not & + support schemes " + errflg = 1 + return + endif +! + if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then + + print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag + print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only + print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl + write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & + support with but has Logic error" + errflg = 1 + return + endif +!========================== +! +! initialize ugwp_common +! con_pi, con_rerth, con_p0, con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt +! +!========================== + + pi = con_pi + arad = con_rerth + p0s = con_p0 + grav = con_g + omega1= con_omega + cpd = con_cp + rd = con_rd + rv = con_rv + fv = con_fvirt + + grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav + rdi = 1.0 / rd ; rcpd = 1./cpd; rcpd2 = 0.5/cpd + gor = grav/rd + gr2 = grav*gor + grcp = grav*rcpd + gocp = grcp + rcpdl = cpd*rgrav + grav2cpd = grav*grcp + + pi2 = 2.*pi ; pih = .5*pi + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + + bnv2min = (pi2/1800.)*(pi2/1800.) + bnv2max = (pi2/30.)*(pi2/30.) + dw2min = 1.0 + velmin = sqrt(dw2min) + minvel = 0.5 + + omega2 = 2.*omega1 + omega3 = 3.*omega1 + + hpscale = 7000. ; hpskm = hpscale*1.e-3 + rhp = 1./hpscale + rhp2 = 0.5*rhp; rh4 = 0.25*rhp + rhp4 = rhp2 * rhp2 + khp = rhp* rd/cpd + mkzmin = pi2/80.0e3 + mkz2min = mkzmin*mkzmin + mkzmax = pi2/500. + mkz2max = mkzmax*mkzmax + cdmin = 2.e-2/mkzmax + + rcpdt = rcpd/dtp + + if ( do_ugwp_v1 ) then + call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & + con_p0, dtp, errmsg, errflg) + end if + + if (me == master) then + print *, ' ccpp: ugwpv1_gsldrag_init ' + + print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 + print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl + print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss + print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd + + print *, ' ccpp: ugwpv1_gsldrag_init ' + endif + + + + is_initialized = .true. + + + end subroutine ugwpv1_gsldrag_init + + +! ----------------------------------------------------------------------- +! finalize of ugwpv1_gsldrag (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP + +!> \section arg_table_ugwpv1_gsldrag_finalize Argument Table +!! \htmlinclude ugwpv1_gsldrag_finalize.html +!! + + subroutine ugwpv1_gsldrag_finalize(errmsg, errflg) + + implicit none +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call cires_ugwp_dealloc + + is_initialized = .false. + + end subroutine ugwpv1_gsldrag_finalize + + +! ----------------------------------------------------------------------- +! originally from ugwp_driver_v0.f +! driver of cires_ugwp (_driver) +! ----------------------------------------------------------------------- +! driver is called after pbl & before chem-parameterizations +! ----------------------------------------------------------------------- +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +! ----------------------------------------------------------------------- +!>@brief These subroutines and modules execute the CIRES UGWP Version 0 +!>\defgroup ugwpv1_gsldrag_run Unified Gravity Wave Physics General Algorithm +!> @{ +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! +!! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. +!! +!> \section arg_table_ugwpv1_gsldrag_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_run.html +!! +!> \section gen_ugwpv1_gsldrag CIRES UGWP Scheme General Algorithm +!! @{ + subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & + gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & +! con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & + nmtvr, hprime, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & + rain, br1, hpbl, kpbl, slmsk, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, del, tau_amf, & + dudt_ogw, dvdt_ogw, du_ogwcol, dv_ogwcol, & + dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & + dudt_oss, dvdt_oss, du_osscol, dv_osscol, & + dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & + tau_ogw, tau_ngw, tau_oss, & + zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & + lprnt, ipr, errmsg, errflg) +! +!######################################################################## +! Attention New Arrays and Names must be ADDED inside +! +! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta +! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" +!######################################################################## + +! + + use ugwp_common, only : con_pi => pi, con_g => grav, con_rd => rd, & + con_rv => rv, con_cp => cpd, con_fv => fv, & + con_rerth => arad, con_omega => omega1, rgrav + + implicit none + +! Preference use (im,levs) rather than (:,:) to avoid memory-leaks +! that found in Nov-Dec 2020 +! order array-description control-logical +! other in-variables +! out-variables +! local-variables +! +! unified GSL and CIRES diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 +! +! +! interface variables + logical, intent(in) :: ldiag3d, lssav + logical, intent(in) :: flag_for_gwd_generic_tend + logical, intent(in) :: lprnt + + integer, intent(in) :: ipr + +! flags for choosing combination of GW drag schemes to run + + logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd + logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp + logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes + + integer, intent(in) :: me, master, im, levs, ntrac,lonr + real(kind=kind_phys), intent(in) :: dtp, fhzero + integer, intent(in) :: kdt, jdat(8) + +! SSO parameters and variables + integer, intent(in) :: gwd_opt !gwd_opt and nmtvr are "redundant" controls + integer, intent(in) :: nmtvr + real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! for gsl_drag + + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma + + real(kind=kind_phys), intent(in), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx + real(kind=kind_phys), intent(in), dimension(im, 4) :: oa4ss,ol4ss + +!===== +!ccpp-style passing constants, I prefer to take them out from the "call-subr" list +!===== +! real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & +! con_rv, con_rerth, con_fvirt +! grids + + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + +! State vars + PBL/slmsk +rain + + real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii + real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 + integer, intent(in), dimension(im) :: kpbl + + real(kind=kind_phys), intent(in), dimension(im) :: rain + real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk +! +! moved to GFS_phys_time_vary +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau +! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau + real(kind=kind_phys), intent(in), dimension(im) :: tau_amf + +!Output (optional): + + real(kind=kind_phys), intent(out), dimension(im) :: & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol +! +! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) +! du_ngwcol, dv_ngwcol + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: tau_ogw, tau_ngw, tau_oss + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw + + real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw +! +! + real(kind=kind_phys), intent(inout), dimension(im, levs) :: dudt, dvdt, dtdt + +! +! These arrays are only allocated if ldiag=.true. +! +! Version of COORDE updated by CCPP-dev for time-aver +! + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw + + + + real(kind=kind_phys), intent(out), dimension(im) :: rdxzb ! for stoch phys. mtb-level + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + integer :: i, k + real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis +!------------ +! +! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init +! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa +! +! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 +!------------ +! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 + +! switches that activate impact of OGWs and NGWs + +! integer :: nmtvr_temp + + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers + real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces + + +! ugwp_v1 local variables + + integer :: y4, month, day, ddd_ugwp, curdate, curday + +! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 +! diagnostics for wind and temp rms to compare with space-borne data and metrics +! in the Middle atmosphere: 20-110 km ( not active in CCPP-style, oct 2020) +! real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) + + + ! Initialize CCPP error handling variables + + errmsg = '' + errflg = 0 + +! 1) ORO stationary GWs +! ------------------ +! +! for all oro-suites can uze geo-meters having "hpbl" +! +! +! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust +! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" +! + zmeti = phii* rgrav + zmet = phil* rgrav + +!=============================================================== +! ORO-diag + + dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. + dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. + + dusfcg (:) = 0. ; dvsfcg(:) =0. + + du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. + du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. + +! + dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. + +! ngw+ogw - diag + + dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. +! source fluxes + + tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. + +! launch layers + + zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. +!=============================================================== +! diag tendencies due to all-SSO schemes (ORO-physics) +! ogw + obl + oss + ofd ..... no explicit "lee wave trapping" +!=============================================================== + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo +! + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme + ! Note: In case of GSL drag_suite, this includes ss and tofd + + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd) then +! +! to do: the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : +! +! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd +! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol +! dusfcg, dvsfcg +! +! + call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & + ugrs,vgrs,tgrs,q1, & + kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & + kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & + ol4ss,theta,sigma,gamma,elvmax, & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd, & + dusfcg, dvsfcg, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol, & + slmsk,br1,hpbl, con_g,con_cp,con_rd,con_rv, & + con_fv, con_pi, lonr, & + cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & + do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & + errmsg,errflg) +! +! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol +! +! if (kdt <= 2 .and. me == master) then +! print *, ' unified drag_suite_run ', kdt +! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! +! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! +! if (gwd_opt == 22 .or. gwd_opt == 33) then +! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 +! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 +! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 +! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 +! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 +! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 +! endif +! endif + + else +! +! not gsldrag oro-scheme for example "do_ugwp_v1_orog_only" +! + + if ( do_ugwp_v1_orog_only ) then +! +! for TOFD we use now "varss" of GSL-drag /not sgh30=abs(oro-oro_f)/ +! only sum of integrated ORO+GW effects (dusfcg and dvsfcg) = sum(ogw + obl + oss*0 + ofd + ngw) +! +! OROGW_V1 introduce "orchestration" between OGW-effects and Mountain Blocking +! it starts to examines options for the Scale-Aware (SA)formulation of SSO-effects +! if ( me == master .and. kdt == 1) print *, ' bf orogw_v1 nmtvr=', nmtvr, ' do_tofd=', do_tofd + + if (gwd_opt ==1 )sgh30 = 0.15*hprime ! portion of the mesoscale SSO (~[oro_unfilt -oro_filt) + if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run + + call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & + xlat_d, sinlat, coslat, area, & + cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & + sigma, gamma, elvmax, sgh30, kpbl, ugrs, & + vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & + Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) +! +! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms +! +! +! if (kdt <= 2 .and. me == master) then +! +! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr +! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! endif + + + end if +! +! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections +! + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + Pdudt(i,k)*dtp + ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + Pdvdt(i,k)*dtp + ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + Pdtdt(i,k)*dtp + enddo + enddo + endif + ENDIF +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Begin non-stationary GW schemes +! ugwp_v1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (do_ugwp_v1) then + +!================================================================== +! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) +! +! 2020 updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs +!================================================================== + + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) + + y4 = jdat(1); month = jdat(2); day = jdat(3) +! +! hour = jdat(5) +! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. +! fhour = (kdt-1)*dtp/3600. +! fhrday = fhour/24. - nint(fhour/24.) + + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp +! + call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & + tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) + + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & + tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) +! +! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt +! +! if (me == master .and. kdt <= 2) then +! print * +! write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' +! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' +! print * +! +! print *, ' ugwp_v1 ', kdt +! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 +! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 +! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 +! endif + + + end if ! do_ugwp_v1 + +! +! GFS-style diag dt3dt(:.:, 1:14) time-averaged +! + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtp + ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtp + ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtp + enddo + enddo + endif + +! +! get total sso-OGW + NGW +! + dudt_gw = Pdudt +dudt_ngw + dvdt_gw = Pdvdt +dvdt_ngw + dtdt_gw = Pdtdt +dtdt_ngw + kdis_gw = Pkdis +kdis_ngw +! +! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) +! + dudt = dudt + dudt_ngw + dvdt = dvdt + dvdt_ngw + dtdt = dtdt + dtdt_ngw + + end subroutine ugwpv1_gsldrag_run +!! @} +!>@} +end module ugwpv1_gsldrag diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta new file mode 100644 index 000000000..2eac9a321 --- /dev/null +++ b/physics/ugwpv1_gsldrag.meta @@ -0,0 +1,1240 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag + type = scheme + dependencies = machine.F,drag_suite.F90 + dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 + dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for opening namelist file + units = none + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=* + intent = in + optional = F +[logunit] + standard_name = iounit_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in + optional = F +[fn_nml2] + standard_name = namelist_filename + long_name = namelist filename for ugwp + units = none + dimensions = () + type = character + kind = len=* + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[latr] + standard_name = number_of_latitude_points + long_name = number of global points in y-dir (j) along the meridian + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ak] + standard_name = a_parameter_of_the_hybrid_coordinate + long_name = a parameter for sigma pressure level calculations + units = Pa + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[bk] + standard_name = b_parameter_of_the_hybrid_coordinate + long_name = b parameter for sigma pressure level calculations + units = none + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_p0] + standard_name = standard_atmospheric_pressure + long_name = standard atmospheric pressure + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = flag_for_ugwp_version_0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = flag_for_ugwp_version_0_orographic_gwd + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = flag_for_ugwp_version_1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = flag_for_ugwp_version_1_orographic_gwd + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_w_gsldrag] + standard_name = flag_for_ugwp_version_1_nonorographic_gwd + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_run + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fhzero] + standard_name = hours_between_clearing_of_diagnostic_buckets + long_name = hours between clearing of diagnostic buckets + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_gravity_wave_drag_tendency + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = flag_for_ugwp_version_1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = flag_for_ugwp_version_1_orographic_gwd + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_w_gsldrag] + standard_name = flag_for_ugwp_version_1_nonorographic_gwd + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + type = logical + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[do_tofd] + standard_name = turb_oro_form_drag_flag + long_name = flag for turbulent orographic form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of topographic variables in GWD + units = count + dimensions = () + type = integer + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degree + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[varss] + standard_name = standard_deviation_of_subgrid_orography_small_scale + long_name = standard deviation of subgrid orography small scale + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oc1ss] + standard_name = convexity_of_subgrid_orography_small_scale + long_name = convexity of subgrid orography small scale + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oa4ss] + standard_name = asymmetry_of_subgrid_orography_small_scale + long_name = asymmetry of subgrid orography small scale + units = none + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4ss] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale + long_name = horizontal fraction of grid box covered by sso higher than critical height small scale + units = frac + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sinlat] + standard_name = sine_of_latitude + long_name = sine of the grid latitude + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[coslat] + standard_name = cosine_of_latitude + long_name = cosine of the grid latitude + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between midlayers + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_amf] + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ogw] + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = y momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ogwcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag + long_name = integrated x momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ogwcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag + long_name = integrated y momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_obl] + standard_name = tendency_of_x_momentum_due_to_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_obl] + standard_name = tendency_of_y_momentum_due_to_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_oblcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_oblcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_oss] + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_oss] + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_osscol] + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag + long_name = integrated x momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_osscol] + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag + long_name = integrated y momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ofd] + standard_name = tendency_of_x_momentum_due_to_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ofd] + standard_name = tendency_of_y_momentum_due_to_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ofdcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ofdcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag + long_name = integrated y momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ngw] + standard_name = tendency_of_x_wind_due_to_nonorographic_gravity_wave_drag + long_name = zonal wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ngw] + standard_name = tendency_of_y_wind_due_to_nonorographic_gravity_wave_drag + long_name = meridional wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_ngw] + standard_name = tendency_of_air_temperature_due_to_nonorographic_gravity_wave_drag + long_name = air temperature tendency due to non-stationary GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_ngw] + standard_name = atmosphere_momentum_diffusivity_due_to_nonorographic_gravity_wave_drag + long_name = eddy mixing due to non-stationary GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_gw] + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag + long_name = eddy mixing due to all GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_oss] + standard_name = momentum_flux_due_to_subgrid_scale_orographic_gravity_wave_drag + long_name = momentum flux or stress due to SSO including OBL-OSS-OFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity waves + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zobl] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zngw] + standard_name = height_of_launch_level_of_nonorographic_gravity_waves + long_name = height of launch level of non-stationary GWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F + intent = out + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[ldu3dt_ogw] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in x wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ogw] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in y wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ogw] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldu3dt_ngw] + standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in x wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ngw] + standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in y wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ngw] + standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag + long_name = cumulative change in temperature due to convective gravity wave drag + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + + diff --git a/physics/ugwpv1_gsldrag_post.F90 b/physics/ugwpv1_gsldrag_post.F90 new file mode 100644 index 000000000..1d8813f65 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.F90 @@ -0,0 +1,107 @@ +!> \file ugwpv1_gsldrag_post.F90 +!! This file contains +module ugwpv1_gsldrag_post + +contains + +!>\defgroup ugwpv1_gsldrag_post ugwpv1_gsldrag Scheme Post +!! @{ + + subroutine ugwpv1_gsldrag_post_init () + end subroutine ugwpv1_gsldrag_post_init + +!>@brief The subroutine initializes the unified UGWP + +!> \section arg_table_ugwpv1_gsldrag_post_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_post_run.html +!! + + + + subroutine ugwpv1_gsldrag_post_run ( im, levs, & + ldiag_ugwp, dtf, & + dudt_gw, dvdt_gw, dtdt_gw, du_ofdcol, du_oblcol, tau_ogw, & + tau_ngw, zobl, zlwb, zogw, dudt_obl, dudt_ofd, dudt_ogw, & + tot_zmtb, tot_zlwb, tot_zogw, & + tot_tofd, tot_mtb, tot_ogw, tot_ngw, & + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtf + logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics + + real(kind=kind_phys), intent(in), dimension(im) :: zobl, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(im) :: du_ofdcol, tau_ogw, du_oblcol, tau_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw + + real(kind=kind_phys), intent(in), dimension(im,levs) :: dtdt_gw, dudt_gw, dvdt_gw + real(kind=kind_phys), intent(in), dimension(im,levs) :: dudt_obl, dudt_ogw, dudt_ofd + real(kind=kind_phys), intent(inout), dimension(im,levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + + real(kind=kind_phys), intent(inout), dimension(im,levs) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +! post creates the "time-averaged" diagnostics" +! + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zobl + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *du_ofdcol + tot_mtb = tot_mtb + dtf *du_oblcol + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_obl + du3dt_tms = du3dt_tms + dtf *dudt_ofd + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *dudt_gw + dv3dt_ngw = dv3dt_ngw + dtf *dvdt_gw + endif + +!===================================================================== +! Updates inside the ugwpv1_gsldrag.F90 +! +! dtdt = dtdt + dtdt_gw +! dudt = dudt + dudt_gw +! dvdt = dvdt + dvdt_gw +! +! "post" may also create the "time-averaged" diagnostics" +! +! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then +! do k=1,levs +! do i=1,im +! ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtf +! ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtf +! ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtf +! +! ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + dudt_ogw(i,k)*dtf +! ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + dvdt_ogw(i,k)*dtf +! ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + dtdt_ogw(i,k)*dtf +! enddo +! enddo +! endif +! +!===================================================================== + end subroutine ugwpv1_gsldrag_post_run + + subroutine ugwpv1_gsldrag_post_finalize () + end subroutine ugwpv1_gsldrag_post_finalize + +!! @} +end module ugwpv1_gsldrag_post diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta new file mode 100644 index 000000000..45fa4ea99 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.meta @@ -0,0 +1,321 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[du_oblcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[du_ofdcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zobl] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_obl] + standard_name = tendency_of_x_momentum_due_to_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ofd] + standard_name = tendency_of_x_momentum_due_to_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tot_zmtb] + standard_name = time_integral_of_height_of_mountain_blocking + long_name = time integral of height of mountain blocking drag + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zlwb] + standard_name = time_integral_of_height_of_low_level_wave_breaking + long_name = time integral of height of drag due to low level wave breaking + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zogw] + standard_name = time_integral_of_height_of_launch_level_of_orographic_gravity_wave + long_name = time integral of height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_tofd] + standard_name = time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = time integral of momentum flux due to TOFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_mtb] + standard_name = time_integral_of_momentum_flux_due_to_mountain_blocking_drag + long_name = time integral of momentum flux due to mountain blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ogw] + standard_name = time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = time integral of momentum flux due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ngw] + standard_name = time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave + long_name = time integral of momentum flux due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ngw] + standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in x wind due to NGW + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt_ngw] + standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in y wind due to NGW + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_finalize + type = scheme + diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 5c0604f86..7fdc43b2b 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -1,5 +1,5 @@ !> \file unified_ugwp.F90 -!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! This file combines three two orographic GW-schemes cires_ugwp.F90 and drag_suite.F90 under "unified_ugwp" suite: !! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: !! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f !! b) the v0 cires ugwp non-stationary GWD scheme @@ -10,8 +10,6 @@ !! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) !! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km !! (Beljaars et al, 2004 \cite beljaars_et_al_2004) -!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) -!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: !! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers !! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics !! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. @@ -25,11 +23,10 @@ !! The choice of schemes is activated at runtime by the following namelist options (boolean): !! do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD !! do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_ugwp_v0_nst_only -- activates V0 CIRES UGWP scheme - non-stationary GWD only !! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking !! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD !! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag -!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD -!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only !! Note that only one "large-scale" scheme can be activated at a time. !! @@ -37,22 +34,12 @@ module unified_ugwp use machine, only: kind_phys - use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize - - use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp - +! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run use drag_suite, only: drag_suite_run - use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 - - use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 - - ! use cires_ugwp_ngw_utils, only: tau_limb_advance - - use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 - implicit none private @@ -75,9 +62,9 @@ module unified_ugwp subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & - do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & - do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only, errmsg, errflg) + do_ugwp_v0, do_ugwp_v0_orog_only, do_ugwp_v0_nst_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + errmsg, errflg) !---- initialization of unified_ugwp implicit none @@ -98,9 +85,9 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth logical, intent (in) :: do_ugwp logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent (in) :: fn_nml2 !character(len=*), parameter :: fn_nml='input.nml' @@ -120,17 +107,12 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & ! Test to make sure that at most only one large-scale/blocking ! orographic drag scheme is chosen - if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & - do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & - (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & - do_ugwp_v1_orog_only)) .or. & - (do_gsl_drag_ls_bl.and.(do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & - (do_ugwp_v1.and.do_ugwp_v1_orog_only) ) then + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl)) .or. & + (do_ugwp_v0_orog_only.and.do_gsl_drag_ls_bl) ) then write(errmsg,'(*(a))') "Logic error: Only one large-scale& &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& - &do_gsl_drag_ls_bl,do_ugwp_v1 or & - &do_ugwp_v1_orog_only) can be chosen" + &do_gsl_drag_ls_bl can be chosen" errflg = 1 return @@ -140,28 +122,21 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return - if ( do_ugwp_v0 ) then + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) then ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) if (cdmbgwd(3) > 0.0) then - call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + call cires_ugwpv0_mod_init(me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) else write(errmsg,'(*(a))') "Logic error: cires_ugwp_mod_init called but & - &do_ugwp_v0 is true and cdmbgwd(3) <= 0" + &do_ugwp_v0 or do_ugwp_v0_nst_only is true and cdmbgwd(3) <= 0" errflg = 1 return end if end if - if ( do_ugwp_v1 ) then - call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, con_pi, & - con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & - con_p0, dtp, cdmbgwd(1:2), cgwf, pa_rf_in, & - tau_rf_in, errmsg, errflg) - end if - is_initialized = .true. end subroutine unified_ugwp_init @@ -177,11 +152,12 @@ end subroutine unified_ugwp_init !! \htmlinclude unified_ugwp_finalize.html !! - subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & + errmsg, errflg) implicit none ! - logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -191,9 +167,7 @@ subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) if (.not.is_initialized) return - if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() - - if ( do_ugwp_v1 ) call cires_ugwp_finalize() + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -211,7 +185,7 @@ end subroutine unified_ugwp_finalize !>@brief These subroutines and modules execute the CIRES UGWP Version 0 !>\defgroup unified_ugwp_run Unified Gravity Wave Physics General Algorithm !> @{ -!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and backgroufnd dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). !! !! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. !! @@ -229,13 +203,13 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & - dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt_mtb, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & dudt, dvdt, dtdt, rdxzb, con_g, con_omega, con_pi, con_cp, con_rd, con_rv, & con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & - do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + gwd_opt, errmsg, errflg) implicit none @@ -244,10 +218,15 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, integer, intent(in) :: gwd_opt integer, intent(in), dimension(im) :: kpbl real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma - real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss, dx + +!vay-nov 2020 + real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + logical, intent(in) :: flag_for_gwd_generic_tend - ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + + ! elvmax is intent(in) for CIRES UGWPv1, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area @@ -265,7 +244,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & dusfc_ss(:),dvsfc_ss(:), & & dusfc_fd(:),dvsfc_fd(:) real(kind=kind_phys), intent(out) :: & - & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & & dtaux2d_fd(:,:),dtauy2d_fd(:,:) @@ -274,11 +252,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & hpbl(im), & & slmsk(im) - real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg - real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb - real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw - real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis - real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs) :: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(:,:) :: dudt_mtb, dudt_tms + real(kind=kind_phys), intent(out), dimension(:,:) :: dtaux2d_ls, dtauy2d_ls ! These arrays are only allocated if ldiag=.true. real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw @@ -303,9 +282,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! flags for choosing combination of GW drag schemes to run logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -315,12 +294,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im) :: sgh30 real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis - real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt - ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init + real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 - ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) - real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. - real(kind=kind_phys), parameter :: fw1_tau=1.0 + integer :: nmtvr_temp real(kind=kind_phys), dimension(:,:), allocatable :: tke @@ -331,23 +307,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces - - ! ugwp_v1 local variables - integer :: y4, month, day, ddd_ugwp, curdate, curday - integer :: hour - real(kind=kind_phys) :: hcurdate, hcurday, fhour, fhrday - integer :: kdtrest - integer :: curday_ugwp - integer :: curday_save=20150101 - logical :: first_qbo=.true. - real :: hcurday_save =20150101.00 - save first_qbo, curday_save, hcurday_save - - - ! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 - real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) - - ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -355,8 +314,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! 1) ORO stationary GWs ! ------------------ - zlwb(:) = 0. - ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd @@ -375,40 +332,15 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) - - end if - - if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then - - ! Valery's TOFD - ! topo paras - ! w/ orographic effects - if(nmtvr == 14)then - ! calculate sgh30 for TOFD - sgh30 = abs(oro - oro_uf) - ! w/o orographic effects - else - sgh30 = 0. - endif - - inv_g = 1./con_g - zmeti = phii*inv_g - zmet = phil*inv_g - - call gwdps_oro_v1 (im, levs, lonr, do_tofd, & - Pdvdt, Pdudt, Pdtdt, Pkdis, & - ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & - prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & - clx, theta, sigma, gamma, elvmax, & - con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & - con_rerth, con_fvirt, sgh30, DUSFCg, DVSFCg, & - xlat_d, sinlat, coslat, area,cdmbgwd(1:2), me, & - master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, & - tau_tofd, du3dt_mtb, du3dt_ogw, du3dt_tms) - +! +! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls +! + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_tms = 0. + end if - if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only.or.do_ugwp_v0_nst_only ) then do k=1,levs do i=1,im @@ -419,6 +351,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo enddo + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary @@ -466,12 +402,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! ! ugwp_v0 non-stationary GW drag ! - if (do_ugwp_v0) then + if (do_ugwp_v0.or.do_ugwp_v0_nst_only) then if (cdmbgwd(3) > 0.0) then ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing - call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -514,10 +450,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do k=1,levs do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + gw_dtdt(i,k) = gw_dtdt(i,k)+ Pdtdt(i,k) + gw_dudt(i,k) = gw_dudt(i,k)+ Pdudt(i,k) + gw_dvdt(i,k) = gw_dvdt(i,k)+ Pdvdt(i,k) + gw_kdis(i,k) = gw_kdis(i,k)+ Pkdis(i,k) ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) @@ -537,33 +473,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif ! cdmbgwd(3) > 0.0 - - if (pogw == 0.0) then - tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. - dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. - endif - -#if 0 - !============================================================================= - ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving - ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" - !============================================================================= - ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies - !------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & - del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) - gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked - gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked - gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked -#endif - + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im @@ -574,161 +484,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif - end if ! do_ugwp_v0 - - - ! - ! ugwp_v1 non-stationary GW drag - ! - if (do_ugwp_v1) then - -! -------- -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) - - y4 = jdat(1); month = jdat(2); day = jdat(3) ; hour = jdat(5) - - ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. - fhour = (kdt-1)*dtp/3600. - fhrday = fhour/24. - nint(fhour/24.) - fhour = fhrday*24. - - call calendar_ugwp(y4, month, day, ddd_ugwp) - curdate = y4*1000 + ddd_ugwp - curday = y4*10000 + month*100 + day - hcurdate = float(curdate) + fhrday - hcurday = float(curday) + fhrday -! - if (mod(fhour,fhzero) == 0 .or. first_qbo) then - - ! call tau_limb_advance(me, master, im, levs, ddd_ugwp, curdate, & - ! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) - - if (first_qbo) kdtrest = kdt - first_qbo = .false. - curday_save = curday - hcurday_save= hcurday - endif - - ! tau_ngw = fw1_tau*tau_ngw + tau_sat*(1.-fw1_tau) - -! goto 111 -! if (mod(fhour,fhzero) == 0 .or. first_qbo) then - -! call tau_qbo_advance(me, master, im, levs, ddd_ugwp, curdate, & -! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, j1_qbo, j2_qbo, & -! ddy_j1qbo, ddy_j2qbo, tau_sat, tau_qbo, uqbo, ax_qbo, kdt ) - - -! if (me == master) then -! print *, ' curday_save first_qbo ', curday, curday_save, kdt -! print *, ' hcurdays ', hcurdate, float(hour)/24. -! print *, jdat(5), jdat(6), jdat(7), (kdt-1)*dtp/3600., ' calendar ' -!! print *, ' curday curday_ugwp first_qbo ', hcurday, first_qbo -!! print *, ' vay_tau-limb U' , maxval(uqbo), minval(uqbo) -!! print *, ' vay_tau-limb TS' , maxval(tau_sat), minval(tau_sat) -!! print *, ' vay_tau-limb TQ' , maxval(tau_qbo), minval(tau_qbo) -! endif - - -! if (first_qbo) kdtrest = kdt -! first_qbo = .false. -! curday_save = curday -! hcurday_save= hcurday -! endif - - - - -! if (mod(kdt, 720) == 0 .and. me == master ) then -! print *, ' vay_qbo_U' , maxval(uqbo), minval(uqbo) , kdt -! endif - -! wqbo = dtp/taurel -! do k =1, levs -!! sdexpz = wqbo*vert_qbo(k) -! sdexpz = 0.25*vert_qbo(k) -! do i=1, im -!! if (dexpy(i) > 0.0) then -! dforc = 0.25 -!! ugrs(i,k) = ugrs(i,k)*(1.-dforc) + dforc*uqbo(i,levs+1-k) -!! tgrs(i,k) = tgrs(i,k)*(1.-dforc) + dforc*tqbo(i,levs+1-k) -!! endif -! enddo -! enddo - -! 111 continue - - - call cires_ugwp_solv2_v1(im, levs, dtp, & - tgrs, ugrs, vgrs, q1, prsl, prsi, & - zmet, zmeti,prslk, xlat_d, sinlat, coslat, & - con_g, con_cp, con_rd, con_rv, con_omega, & - con_pi, con_fvirt, & - gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & - tauabs, wrms, trms, tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - endif - - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - !+(uqbo(i,levs+1-k)-ugrs(i,k))/21600. - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) ! + pogw*Pkdis(i,k) - enddo - enddo - - - - - if (pogw == 0.0) then -! zmtb = 0.; zogw =0. - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 - endif - -! return - -!============================================================================= -! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving -! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" -!============================================================================= -! -! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies -!------------------------------------------------------------------------------ - -! ed_dudt(:,:) = 0.0 ; ed_dvdt(:,:) = 0.0 ; ed_dtdt(:,:) = 0.0 - - - -! call edmix_ugwp_v1(im, levs, dtp, & -! tgrs, ugrs, vgrs, q1, del, & -! prsl, prsi, phil, prslk, & -! gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & -! ed_dudt, ed_dvdt, ed_dTdt, -! me, master, kdt ) - -! do k=1,levs -! do i=1,im -! gw_dtdt(i,k) = gw_dtdt(i,k) + ed_dtdt(i,k)*pked -! gw_dvdt(i,k) = gw_dvdt(i,k) + ed_dvdt(i,k)*pked -! gw_dudt(i,k) = gw_dudt(i,k) + ed_dudt(i,k)*pked -! enddo -! enddo - - - end if ! do_ugwp_v1 + end if ! do_ugwp_v0.or.do_ugwp_v0_nst_only end subroutine unified_ugwp_run diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 675a68edd..edb8521e0 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,13 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - dependencies = machine.F,cires_ugwp_module.F90,ugwp_driver_v0.F,cires_ugwp_triggers.F90 - dependencies = cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90 - dependencies = cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90 - dependencies = cires_vert_wmsdis.F90,cires_ugwp_module_v1.F90,cires_ugwp_triggers_v1.F90 - dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_solv2_v1_mod.F90 - dependencies = cires_ugwp_orolm97_v1.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 - dependencies = gwdps.f,drag_suite.F90 + + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + dependencies=drag_suite.F90 ######################################################################## [ccpp-arg-table] @@ -192,7 +189,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -200,15 +197,23 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = flag_for_ugwp_version_0_nonorographic_gwd + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -216,7 +221,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -224,29 +229,13 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only - long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -270,16 +259,16 @@ name = unified_ugwp_finalize type = scheme [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP +[do_ugwp_v0_nst_only] + standard_name = flag_for_ugwp_version_0_nonorographic_gwd + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () type = logical @@ -523,80 +512,80 @@ intent = in optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd - long_name = x momentum tendency from large scale gwd + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -604,8 +593,8 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd - long_name = y momentum tendency from large scale gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in y wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -613,7 +602,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -622,7 +611,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -631,7 +620,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -640,7 +629,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -649,7 +638,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -658,7 +647,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -888,7 +877,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -897,7 +886,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -906,7 +895,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -915,7 +904,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -995,17 +984,8 @@ kind = kind_phys intent = out optional = F -[dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag - long_name = instantaneous change in x wind due to orographic gw drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1278,7 +1258,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -1286,15 +1266,23 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = flag_for_ugwp_version_0_nonorographic_gwd + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -1302,7 +1290,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -1310,29 +1298,13 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only - long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only - units = flag - dimensions = () - type = logical - intent = in - optional = F [gwd_opt] standard_name = gwd_opt long_name = flag to choose gwd scheme diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index 85a6bff8e..0e30d4489 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension)