diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 index 09c969162..2ab0fb37a 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic.F90 @@ -83,7 +83,7 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = 0.0 clx(:,3) = 0.0 clx(:,4) = 0.0 - elseif (nmtvr == 24) then ! GSD_drag_suite + elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) @@ -93,6 +93,10 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,2) = mntvar(:,8) clx(:,3) = mntvar(:,9) clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) varss(:) = mntvar(:,15) ocss(:) = mntvar(:,16) oa4ss(:,1) = mntvar(:,17) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 35b44ca0e..4680f8de7 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -311,7 +311,37 @@ module GFS_diagtoscreen contains - subroutine GFS_diagtoscreen_init () +!> \section arg_table_GFS_diagtoscreen_init Argument Table +!! \htmlinclude GFS_diagtoscreen_init.html +!! + subroutine GFS_diagtoscreen_init (Model, Data, Interstitial, errmsg, errflg) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type, & + GFS_interstitial_type + + implicit none + + !--- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_data_type), intent(in) :: Data(:) + type(GFS_interstitial_type), intent(in) :: Interstitial(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,size(Data) + call GFS_diagtoscreen_run (Model, Data(i)%Statein, Data(i)%Stateout, Data(i)%Sfcprop, & + Data(i)%Coupling, Data(i)%Grid, Data(i)%Tbd, Data(i)%Cldprop, & + Data(i)%Radtend, Data(i)%Intdiag, Interstitial(1), & + size(Interstitial), i, errmsg, errflg) + end do + end subroutine GFS_diagtoscreen_init subroutine GFS_diagtoscreen_finalize () @@ -330,7 +360,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #ifdef OPENMP use omp_lib #endif - use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_statein_type, & GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & @@ -831,7 +860,35 @@ module GFS_interstitialtoscreen contains - subroutine GFS_interstitialtoscreen_init () + subroutine GFS_interstitialtoscreen_init (Model, Data, Interstitial, errmsg, errflg) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type, & + GFS_interstitial_type + + implicit none + + !--- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_data_type), intent(in) :: Data(:) + type(GFS_interstitial_type), intent(in) :: Interstitial(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + do i=1,size(Interstitial) + call GFS_interstitialtoscreen_run (Model, Data(1)%Statein, Data(1)%Stateout, Data(1)%Sfcprop, & + Data(1)%Coupling, Data(1)%Grid, Data(1)%Tbd, Data(1)%Cldprop, & + Data(1)%Radtend, Data(1)%Intdiag, Interstitial(i), & + size(Interstitial), -999, errmsg, errflg) + end do + end subroutine GFS_interstitialtoscreen_init subroutine GFS_interstitialtoscreen_finalize () diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 2595da086..3b044904b 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -3,6 +3,52 @@ type = scheme dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = GFS_diagtoscreen_init + type = scheme +[Model] + standard_name = GFS_control_type_instance + long_name = instance of derived type GFS_control_type in FV3 + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[Data] + standard_name = GFS_data_type_instance_all_blocks + long_name = instance of derived type GFS_data_type + units = DDT + dimensions = (ccpp_block_count) + type = GFS_data_type + intent = in + optional = F +[Interstitial] + standard_name = GFS_interstitial_type_instance_all_threads + long_name = instance of derived type GFS_interstitial_type + units = DDT + dimensions = (omp_threads) + type = GFS_interstitial_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_diagtoscreen_run @@ -135,6 +181,52 @@ type = scheme dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = GFS_interstitialtoscreen_init + type = scheme +[Model] + standard_name = GFS_control_type_instance + long_name = instance of derived type GFS_control_type in FV3 + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[Data] + standard_name = GFS_data_type_instance_all_blocks + long_name = instance of derived type GFS_data_type + units = DDT + dimensions = (ccpp_block_count) + type = GFS_data_type + intent = in + optional = F +[Interstitial] + standard_name = GFS_interstitial_type_instance_all_threads + long_name = instance of derived type GFS_interstitial_type + units = DDT + dimensions = (omp_threads) + type = GFS_interstitial_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_interstitialtoscreen_run diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index cc61662d2..6cbf35f03 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -24,15 +24,15 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & - zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat,& - tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & - qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, ocean, wet, hice, cice, zorl, zorlo, zorll, zorli, zorl_wat, & + zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & + qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & min_lakeice, min_seaice, errmsg, errflg) implicit none @@ -42,9 +42,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx logical, intent(in ) :: frac_grid, cplflx, cplwav2atm logical, dimension(im), intent(inout) :: flag_cice logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet - real(kind=kind_phys), intent(in ) :: cimin real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac - real(kind=kind_phys), dimension(im), intent(inout) :: cice + real(kind=kind_phys), dimension(im), intent(inout) :: cice, hice real(kind=kind_phys), dimension(im), intent( out) :: frland real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd, qss, hflx @@ -55,11 +54,13 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(im), intent(inout) :: islmsk + integer, dimension(im), intent(inout) :: islmsk, islmsk_cice real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad - real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice + real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -76,37 +77,49 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx frland(i) = landfrac(i) if (frland(i) > zero) dry(i) = .true. if (frland(i) < one) then - if (flag_cice(i)) then + if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + endif + islmsk(i) = 2 else cice(i) = zero + hice(i) = zero flag_cice(i) = .false. -! islmsk_cice(i) = 0 -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists + islmsk_cice(i) = 0 + islmsk(i) = 0 + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif else if (cice(i) >= min_lakeice) then icy(i) = .true. - if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists islmsk(i) = 2 + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists + hice(i) = zero + islmsk(i) = 0 endif - endif - if (wet(i) .and. .not. cplflx) then - if (oceanfrac(i) > zero) then - tsfco(i) = max(tsfco(i), tisfc(i), tgice) - elseif (icy(i)) then - tsfco(i) = max(tisfc(i), tgice) + islmsk_cice(i) = islmsk(i) + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif - else + else ! all land cice(i) = zero + hice(i) = zero + islmsk_cice(i) = 1 + islmsk(i) = 1 endif enddo @@ -118,27 +131,39 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx dry(i) = .true. frland(i) = one cice(i) = zero + hice(i) = zero else frland(i) = zero - if (flag_cice(i)) then - if (cice(i) > min_seaice) then - icy(i) = .true. + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero + hice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 + islmsk_cice(i) = 0 + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif else - if (cice(i) > min_lakeice) then + if (cice(i) >= min_lakeice) then icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. islmsk(i) = 0 endif - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + islmsk_cice(i) = islmsk(i) + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif endif endif enddo @@ -170,7 +195,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! snowd_wat(i) = snowd(i) weasd_wat(i) = zero snowd_wat(i) = zero - semis_wat(i) = 0.984d0 + semis_wat(i) = 0.984_kind_phys qss_wat(i) = qss(i) hflx_wat(i) = hflx(i) endif @@ -198,6 +223,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_ice(i) = qss(i) hflx_ice(i) = hflx(i) endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category @@ -364,7 +390,7 @@ subroutine GFS_surface_composites_post_run ( ! Local variables integer :: i, k - real(kind=kind_phys) :: txl, txi, txo, tem + real(kind=kind_phys) :: txl, txi, txo, wfrac ! Initialize CCPP error handling variables errmsg = '' @@ -377,9 +403,10 @@ subroutine GFS_surface_composites_post_run ( do i=1, im ! Three-way composites (fields from sfc_diff) - txl = landfrac(i) - txi = cice(i)*(one - txl) ! txi = ice fraction wrt whole cell - txo = max(zero, one - txl - txi) + txl = landfrac(i) ! land fraction + wfrac = one - txl ! ocean fraction + txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell + txo = max(zero, wfrac-txi) ! txo = open water fraction zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) @@ -404,11 +431,10 @@ subroutine GFS_surface_composites_post_run ( !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) if (.not. flag_cice(i) .and. islmsk(i) == 2) then - tem = one - txl - evap(i) = txl*evap_lnd(i) + tem*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + tem*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + tem*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + tem*gflx_ice(i) + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) @@ -451,14 +477,18 @@ subroutine GFS_surface_composites_post_run ( ! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! endif - if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) - hice(i) = zero - cice(i) = zero - tisfc(i) = tsfc(i) - endif +! if (.not. flag_cice(i)) then +! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array +! tisfc(i) = tice(i) +! else ! this would be over open ocean or land (no ice fraction) +! hice(i) = zero +! cice(i) = zero +! tisfc(i) = tsfc(i) +! endif +! endif + if (.not. icy(i)) then + hice(i) = zero + cice(i) = zero endif enddo @@ -478,6 +508,9 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_lnd(i) !tsurf(i) = tsurf_lnd(i) tsfcl(i) = tsfc_lnd(i) ! over land + tsfc(i) = tsfcl(i) + tsfco(i) = tsfc(i) + tisfc(i) = tsfc(i) cmm(i) = cmm_lnd(i) chh(i) = chh_lnd(i) gflx(i) = gflx_lnd(i) @@ -488,11 +521,8 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) - tsfc(i) = tsfc_lnd(i) hice(i) = zero cice(i) = zero - tisfc(i) = tsfc(i) - tsfco(i) = tsfc(i) elseif (islmsk(i) == 0) then zorl(i) = zorl_wat(i) cd(i) = cd_wat(i) @@ -506,7 +536,9 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_wat(i) !tsurf(i) = tsurf_wat(i) tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) + tsfc(i) = tsfco(i) tsfcl(i) = tsfc(i) + tisfc(i) = tsfc(i) cmm(i) = cmm_wat(i) chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) @@ -517,10 +549,8 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) - tsfc(i) = tsfc_wat(i) hice(i) = zero cice(i) = zero - tisfc(i) = tsfc(i) else ! islmsk(i) == 2 zorl(i) = zorl_ice(i) cd(i) = cd_ice(i) @@ -544,12 +574,13 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) + tisfc(i) = tice(i) if (.not. flag_cice(i)) then - tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) +! tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) - tsfc(i) = tsfc_ice(i) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) elseif (wet(i)) then - if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) @@ -576,7 +607,7 @@ subroutine GFS_surface_composites_post_run ( endif tsfcl(i) = tsfc(i) do k=1,kice ! store tiice in stc to reduce output in the nonfrac grid case - stc(i,k)=tiice(i,k) + stc(i,k) = tiice(i,k) end do endif diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 71765b9a2..21b308357 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -140,23 +140,23 @@ type = logical intent = inout optional = F -[cice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout optional = F -[cimin] - standard_name = minimum_sea_ice_concentration - long_name = minimum sea ice concentration +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water units = frac - dimensions = () + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout optional = F [zorl] standard_name = surface_roughness_length @@ -506,7 +506,24 @@ units = flag dimensions = (horizontal_loop_extent) type = integer - intent = in + intent = inout + optional = F +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + 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 = inout optional = F [semis_rad] standard_name = surface_longwave_emissivity diff --git a/physics/cires_orowam2017.F90 b/physics/cires_orowam2017.F90 new file mode 100644 index 000000000..d5fda5cc0 --- /dev/null +++ b/physics/cires_orowam2017.F90 @@ -0,0 +1,354 @@ +module cires_orowam2017 + + +contains + + + subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & + & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & + & grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + & sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys +! + implicit none + + integer :: im, levs + integer :: npt + integer :: kdt, me, master + integer :: kref(im), ipt(im) + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, & + & hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: & + & u1, v1, t1, bn2, rho, prsl, del + real(kind=kind_phys), intent(in) :: grav, omega, con_rd + + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi +! +! out : taup, taud, pkdis +! + real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup + real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud + real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis + real(kind=kind_phys) :: belps, aelps, nhills, selps +! +! multiwave oro-spectra +! locals +! + integer :: i, j, k, isp, iw + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real :: akx(nworo), cxoro(nworo), akx2(nworo) + real :: aspkx(nworo), c2f2(nworo) , cdf2(nworo) + real :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real :: tau_kx(nworo),taub_kx(nworo) + real, dimension(nworo, levs+1) :: wrms, akzw + + real :: tauz(levs+1), rms_wind(levs+1) + real :: wave_act(nworo,levs+1) + + real :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real :: rayf, kturb + real :: uz, bv, bv2,kxsp, fcor2, cf2 + + real :: fdis + real :: wfdm, wfdt, wfim, wfit + real :: betadis, betam, betat, kds, cx, rhofac + real :: etwk, etws, tauk, cx2sat + real :: cdf1, tau_norm +! +! mean flow +! + real, dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + + integer :: nw, nzi, ksrc + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then +771 format( 'vay-oro19 ', 3(2x,F8.3)) + write(6,771) & + & maxval(tau_kx)*maxval(taub)*1.e3, & + & minval(tau_kx), maxval(tau_kx) + endif +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & + & prsi(j,:), prsL(j,:), grav, con_rd, & + & del(j,:), rho(i,:), & + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & + & xn(i), yn(i)) + + fcor2 = (2*omega*sinlat(j))*(2*omega*sinlat(j))*fc_flag + + k = ksrc + + bv2 = bn2(i,k) + uz = uzi(k) !u1(j,ksrc)*xn(i)+v1(j,ksrc)*yn(i)! + kturb = ktur(k) + rayf = kalp(k) + rhoint = rhoi(k) + dzmet = dzi(k) + kzw = max(sqrt(bv2)/max(cxmin, uz), mkzmin) +! +! specify oro-kx spectra and related variables k=ksrc +! + do iw = 1, nw + kxw = akx(iw) + cxoro(iw) = 0.0 - uz + c2f2(iw) = fcor2/akx2(iw) + wrms(iw,k)= taub_kx(iw)/rhoint*kzw/kxw + tau_sp(iw, k) = taub_kx(iw) +! +! + if (cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0. ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) then + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off + else + kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) + kzw = sqrt(kzw2) + akzw(iw,k)= kzw + wrms(iw,k)= taub_kx(iw)/rhoint * kzw/kxw + endif + endif + enddo ! nw-spectral loop +! +! defined abobe, k = ksrc: akx(nworo), cxoro(nworo), tau_sp(ksrc, nworo) +! propagate upward multiwave-spectra are filtered by dissipation & instability +! +! tau_sp(:,ksrc+1:levs+1) = tau_sp(:, ksrc) + do k= ksrc+1, levs + uz = uzi(k) + bv2 =bn2(i,k) + bv = sqrt(bv2) + rayf = kalp(k) + rhoint= rhoi(k) + dzmet = dzi(k) + rhofac = rhoi(k-1)/rhoi(k) + + do iw = 1, nworo +! + if (wave_act(iw, k-1) <= 0.0) cycle + cxoro(iw)= 0.0 - uz + if ( cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0.0 ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) wave_act(iw,k:levs+1) = 0.0 + endif + if ( wave_act(iw,k) <= 0.0) cycle +! +! upward propagation +! + kzw2 = Bv2/Cdf2(iw) - akx2(iw) + + if (kzw2 < mkz2min) then + wave_act(iw,k:levs+1) = 0.0 + else +! +! upward propagation w/o reflection +! + kxw = akx(iw) + kzw = sqrt(kzw2) + akzw(iw,k) = kzw + kzw3 = kzw2*kzw + + cx = cxoro(iw) + betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + kds = wkdis(iw,k-1) + + etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) + + kturb = ktur(k)+pkdis(j,k-1) + wfiM = kturb*kzw2 +rayf + wfiT = wfiM ! do updates with Pr-numbers Kv/Kt + cdf1 = sqrt(Cdf2(iw)) + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cdf1)*BetaT + kzi = 2.*kzw*(wfdM+wfdT)*dzmet + Fdis = exp(-kzi) + + etwk = etws*Fdis + Cx2sat = Linsat2*Cdf2(iw) + + if (etwk > cx2sat) then + Kds = kxw*Cdf1*rhp2/kzw3 + etwk = cx2sat + wfiM = kds*kzw2 + wfdM = wfiM/(kxw*Cdf1) + kzi = 2.*kzw*(wfdm + wfdm)*dzmet + etwk = cx2sat*exp(-kzi) + endif +! if( lat(j) eq 40.5 ) then stop + wkdis(iw,k) = kds + wrms(iw,k) = etwk + tauk = etwk*kxw/kzw + tau_sp(iw,k) = tauk *rhoint + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) & + & tau_sp(iw,k) = tau_sp(iw,k-1) + + ENDIF ! upward + ENDDO ! spectral + +!......... do spectral sum of rms, wkdis, tau + + tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) + rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau + + if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax + + ENDDO ! k=ksrc+1, levs + + k = ksrc + tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) + tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) + rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) + tauz(levs+1) = tauz(levs) + taup(i, 1:levs+1) = tauz(1:levs+1) + do k=ksrc, levs + taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +!23456 + end subroutine oro_wam_2017 +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & grav, con_rd, & + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + + use ugwp_common_v1 , only : velmin, dw2min + implicit none + + integer :: nz, nzi + real, dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real, dimension(nz ) :: bn2 ! define at the interfaces + real, dimension(nz+1) :: pint + real :: xn, yn + real,intent(in) :: grav, con_rd +! output + + real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real :: zgrow, zmet, rdpm, ritur, kmol, w1 + real :: rgrav, rdi +! paremeters + real, parameter :: hps = 7000., rpspa = 1.e-5 + real, parameter :: rhps=1.0/hps + real, parameter :: h4= 0.25/hps + real, parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real, parameter :: lturb = 30. , uturb = 150.0 + real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + kalp(1:nzi) = 2.e-7 ! radiative damping + + rgrav = 1.0/grav + rdi = 1.0/con_rd + + do k=2, nz + rdpm = grav/(pmid(k-1)-pmid(k)) + ui = .5*(u1(k-1)+u1(k)) + vi = .5*(v1(k-1)+v1(k)) + uzi(k) = Ui*xn + Vi*yn + ti = .5*(t1(k-1)+t1(k)) + rhoi(k) = rdi*pint(k)/ti + rdz = rdpm *rhoi(k) + dzi(k) = 1./rdz + uz = u1(k)-u1(k-1) + vz = v1(k)-v1(k-1) + shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) + zmet = -hps*alog(pint(k)*rpspa) + zgrow = exp(zmet*h4) + kmol = 2.e-5*exp(zmet*rhps)+kedmin + ritur = max(bn2(k)/shr2, rimin) + kamp = sqrt(shr2)*lsc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k) = kamp * w1 * w1 +kmol + enddo + + k = 1 + uzi(k) = uzi(k+1) + ktur(k) = ktur(k+1) + rhoi(k) = rdi*pint(k)/t1(k+1) + dzi(k) = rgrav*delp(k)/rhoi(k) + + k = nzi + uzi(k) = uzi(k-1) + ktur(k) = ktur(k-1) + rhoi(k) = rhoi(k-1)*.5 + dzi(k) = dzi(k-1) + + end subroutine oro_meanflow + +end module cires_orowam2017 diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index f24ae39ae..21b331041 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -155,7 +155,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & - rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + con_omega, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, errmsg, errflg) @@ -192,7 +192,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, con_omega real(kind=kind_phys), intent(in), dimension(im) :: rain @@ -245,8 +245,8 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & - me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - dudt_mtb, dudt_ogw, dudt_tms) + me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) else ! calling old GFS gravity wave drag as is diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index 3dda6a07c..d7d7da286 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -806,6 +806,15 @@ kind = kind_phys intent = in optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [rain] standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep long_name = total rain at this time step diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 new file mode 100644 index 000000000..4258680ea --- /dev/null +++ b/physics/cires_ugwp_initialize_v1.F90 @@ -0,0 +1,805 @@ +!=============================== +! cu-cires ugwp-scheme +! initialization of selected +! init gw-solvers (1,2,3,4) +! init gw-source specifications +! init gw-background dissipation +!============================== +! +! Part-0 specifications of common constants, limiters and "criiical" values +! +! + + module ugwp_common_v1 +! +! use machine, only : kind_phys +! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & +! rv => con_rv, cpd => con_cp, fv => con_fvirt,& +! arad => con_rerth + implicit none + + real, parameter :: grav =9.81, cpd = 1004. + real, parameter :: rd = 287.0 , rv =461.5 + real, parameter :: grav2 = grav + grav + real, parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real, parameter :: fv = rv/rd - 1.0 + real, parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd + real, parameter :: gor = grav/rd + real, parameter :: gr2 = grav*gor + real, parameter :: grcp = grav*rcpd, gocp = grcp + real, parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + real, parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + + real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi + real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 + + real, parameter :: arad = 6370.e3 +! + real, parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) + real, parameter :: bnv2max = (pi2/30.)*(pi2/30.) + + real, parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 + real, parameter :: omega1 = pi2/86400. + real, parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 + real, parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp + real, parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin + real, parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax + real, parameter :: cdmin = 2.e-2/mkzmax + end module ugwp_common_v1 +! +! +!=================================================== +! +!Part-1 init => wave dissipation + RFriction +! +!=================================================== + subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + pa_rf, tau_rf, me, master) + + + implicit none + integer , intent(in) :: me, master + integer , intent(in) :: levs + real, intent(in) :: con_pi, pa_rf, tau_rf + real, intent(in) :: zkm(levs), pmb(levs) ! in km-Pa + real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion +! +!locals + data +! + integer :: k + real, parameter :: vusurf = 2.e-5 + real, parameter :: musurf = vusurf/1.95 + real, parameter :: hpmol = 8.5 +! + real, parameter :: kzmin = 0.1 + real, parameter :: kturbo = 100. + real, parameter :: zturbo = 130. + real, parameter :: zturw = 30. + real, parameter :: inv_pra = 3. !kt/kv =inv_pr +! + real, parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days + real :: pa_alp = 750. ! super-RF parameters + real :: tau_alp = 10. ! days (750 Pa /10days) +! + real, parameter :: kdrag = 1./86400./30. !parametrization for WAM for FV3GFS SuperRF + real, parameter :: zdrag = 100. + real, parameter :: zgrow = 50. +! + real :: vumol, mumol, keddy, ion_drag + real :: rf_fv3, rtau_fv3, ptop, pih_dlog +! + real :: ae1 ,ae2 + real :: pih + + pih = 0.5*con_pi + + pa_alp = pa_rf + tau_alp = tau_rf + + ptop = pmb(levs) + rtau_fv3 = 1./86400./tau_alp + pih_dlog = pih/log(pa_alp/ptop) + + do k=1, levs + ae1 = -zkm(k)/hpmol + vumol = vusurf*exp(ae1) + mumol = musurf*exp(ae1) + ae2 = -((zkm(k)-zturbo) /zturw)**2 + keddy = kturbo*exp(ae2) + + kvg(k) = vumol + keddy + ktg(k) = mumol + keddy*inv_pra + + krad(k) = alpha +! + ion_drag = kdrag +! + kion(k) = ion_drag! +! add Rayleigh_Super of FV3 for pmb < pa_alp +! + if (pmb(k) .le. pa_alp) then + rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 + krad(k) = krad(k) + rf_fv3 + kion(k) = kion(k) + rf_fv3 + + endif + +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) + enddo + + k= levs+1 + kion(k) = kion(k-1) + krad(k) = krad(k-1) + kvg(k) = kvg(k-1) + ktg(k) = ktg(k-1) + if (me == master) then + write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ' + do k=1, levs, 1 + write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) + enddo + endif +! + 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) + + end subroutine init_global_gwdis_v1 +! +! + subroutine rf_damp_init_v1(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + implicit none + + integer :: levs + real :: pa_rf, tau_rf + real :: dtp + + real :: pmb(levs) + real :: rfdis(levs), rfdist(levs) + integer :: levs_rf + + real :: krf, krfz + integer :: k +! + rfdis(1:levs) = 1.0 + rfdist(1:levs) = 0.0 + levs_rf = levs + if (tau_rf <= 0.0 .or. pa_rf == 0.0) return + + krf = 1.0/(tau_rf*86400.0) + + do k=levs, 1, -1 + if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" + krfz = krf*log(pa_rf/pmb(k)) + rfdis(k) = 1.0/(1.+krfz*dtp) + rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp + levs_rf = k + endif + enddo + + end subroutine rf_damp_init_v1 +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init_v1 +! +!========================================================================= + module ugwp_oro_init_v1 + + use ugwp_common_v1, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common_v1, only : mkzmin, mkz2min + implicit none +! +! constants and "crirtical" values to run oro-mtb_gw physics +! +! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' +! +! + real, parameter :: hncrit=9000. ! max value in meters for elvmax + real, parameter :: hminmt=50. ! min mtn height (*j*) + real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor +! +! + real, parameter :: minwnd=1.0 ! min wind component (*j*) + real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + real, parameter :: hpmax=2400.0, hpmin=25.0 + + character(len=8) :: strver = 'gfs_2018' + character(len=8) :: strbase = 'gfs_2018' + real, parameter :: rimin=-10., ric=0.25 + +! + real, parameter :: efmin=0.5, efmax=10.0 + + + real, parameter :: sigma_std=1./100., gamm_std=1.0 + + real, parameter :: frmax=10., frc =1.0, frmin =0.01 +! + + real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 +! + real, parameter :: rlolev=50000.0 +! + + +! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt + + + + real, parameter :: kxoro=6.28e-3/200. ! + real, parameter :: coro = 0.0 + integer, parameter :: nridge=2 + + real :: cdmb ! scale factors for mtb + real :: cleff ! scale factors for orogw + integer :: nworo ! number of waves + integer :: nazoro ! number of azimuths + integer :: nstoro ! flag for stochastic launch above SG-peak + + integer, parameter :: mdir = 8 + real, parameter :: fdir=.5*mdir/pi + + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir + + real, parameter :: odmin = 0.1, odmax = 10.0 +!------------------------------------------------------------------------------ +! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS +!------------------------------------------------------------------------------ + + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters + real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km +!------------------------------------------------------------------------------ +! + real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm + real, parameter :: fcrit_gfs = 0.7 + real, parameter :: fcrit_mtb = 0.7 + + real, parameter :: zbr_pi = (1.0/2.0)*pi + real, parameter :: zbr_ifs = 0.5*pi + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw, cdmbgwd ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) + ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 + real :: cdmbX + real :: kxw + real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now +!-----------------------------! GFS-setup for cdmb & cleff +! cdmb = 4.0 * (192.0/IMX) +! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) +! + real, parameter :: lonr_refmb = 4.0 * 192.0 + real, parameter :: lonr_refgw = 192.0 + +! copy to "ugwp_oro_init_v1" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + cdmb = cdmbX + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + + cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac + +!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac + + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +! +!.................................................................... +! higher res => smaller h' ..&.. higher kx +! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) +!.................................................................... +! +! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) + end subroutine init_oro_gws +! + + end module ugwp_oro_init_v1 +! ========================================================================= +! +! ugwp_conv_init_v1 +! +!========================================================================= + module ugwp_conv_init_v1 + + implicit none + real :: eff_con ! scale factors for conv GWs + integer :: nwcon ! number of waves + integer :: nazcon ! number of azimuths + integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud + real :: con_dlength + real :: con_cldf + + real, parameter :: cmin = 5 !2.5 + real, parameter :: cmax = 95. !82.5 + real, parameter :: cmid = 22.5 + real, parameter :: cwid = cmid + real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real, parameter :: mstar = 6.28e-3/2. ! 2km + real :: dc + + real, allocatable :: ch_conv(:), spf_conv(:) + real, allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & + con_pi, arad, lonr, kxw, cgwf) + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: con_pi, arad + real :: cgwf(2) + real :: kxw, effac + real :: work1 = 0.5 + real :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = 2.0*con_pi*arad/float(lonr) + con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) +! +! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" +! + if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) + if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) + if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) + if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) +! +! we may use different spectral "shapes" +! for example FVS-93 "Desabeius" +! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail +! + do k = 1,nwaves + chk = cmin + (k-1)*dc + tn4 = (mstar*chk)**4 + ch_conv(k) = chk + spf_conv(k) = bns4*chk/(bns4+tn4) + enddo + + snorm = sum(spf_conv) + spf_conv = spf_conv/snorm*1.5 + + call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init_v1 +!========================================================================= +! +! ugwp_fjet_init_v1 +! +!========================================================================= + + module ugwp_fjet_init_v1 + implicit none + real :: eff_fj ! scale factors for conv GWs + integer :: nwfj ! number of waves + integer :: nazfj ! number of azimuths + integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_fjet(:) , spf_fjet(:) + real, allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: con_pi + real :: kxw, effac , chk + + integer :: k + + nwfj = nwaves + nazfj = nazdir + nstfj = nstoch + eff_fj = effac + + if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) + if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) + if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) + if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_fjet(k) = chk + spf_fjet(k) = 1.0 + enddo + call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init_v1 +! +!========================================================================= +! +! + module ugwp_okw_init_v1 +!========================================================================= + implicit none + + real :: eff_okw ! scale factors for conv GWs + integer :: nwokw ! number of waves + integer :: nazokw ! number of azimuths + integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud +! + real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real, parameter :: cmin = 2.5 + real, parameter :: cmax = 67.5 + real :: dc + real, allocatable :: ch_okwp(:), spf_okwp(:) + real, allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real :: con_pi + real :: kxw, effac , chk + + integer :: k + + nwokw = nwaves + nazokw = nazdir + nstokw = nstoch + eff_okw = effac + + if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) + if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) + if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) + if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_okwp(k) = chk + spf_okwp(k) = 1. + enddo + + call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) + + end subroutine init_okw_gws + + end module ugwp_okw_init_v1 + +!=============================== end of GW sources +! +! init specific gw-solvers (1,2,3,4) +! + +!=============================== +! Part -3 init wave solvers +!=============================== + + module ugwp_lsatdis_init_v1 + implicit none + + integer :: nwav, nazd + integer :: nst + real :: eff + integer, parameter :: incdim = 4, iazdim = 4 +! + contains + + subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + + implicit none +! + integer :: me, master + integer :: nwaves, nazdir + integer :: nstoch + real :: effac + logical :: do_physb + real :: kxw +! +!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces +! are not actibve +! + integer :: inc, jk, jl, iazi, i, j, k + + if( nwaves == 0 .or. nstoch == 1 ) then +! redefine from the default + nwav = incdim + nazd = iazdim + nst = 0 + eff = 1.0 + else +! from input_nml multi-wave spectra + nwav = nwaves + nazd = nazdir + nst = nstoch + eff = effac + endif +! + end subroutine initsolv_lsatdis +! + end module ugwp_lsatdis_init_v1 +! +! + module ugwp_wmsdis_init_v1 + + use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 + use ugwp_common_v1, only : bnv2max, bnv2min, minvel + use ugwp_common_v1, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin + implicit none + + real, parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 + real, parameter :: dked_min =0.01, dked_max=250.0 + + real, parameter :: gptwo=2.0 + + real , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real , parameter :: bnfix4 = bnfix2 * bnfix2 + real , parameter :: bnfix3 = bnfix2 * bnfix +! +! make parameter list that will be passed to SOLVER +! +! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level +! integer, parameter :: ilaunch=klaunch + + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + real , parameter :: ucrit=cdmin + + real , parameter :: zcimin = 2.5 + real , parameter :: zcimax = 125.0 + real , parameter :: zgam = 0.25 +! +! Verical spectra +! + real , parameter :: pind_wd = 5./3. + real , parameter :: sind_kz = 1. + real , parameter :: tind_kz = 3. + real , parameter :: stind_kz = sind_kz + tind_kz +! +! from kmob_ugwp namelist +! + real :: nslope ! the GW sprctral slope at small-m + real :: lzstar + real :: lzmin + real :: lzmax + real :: lhmet + real :: tamp_mpa !amplitude for GEOS-5/MERRA-2 + real :: tau_min ! min of GW MF 0.25 mPa + integer :: ilaunch + real :: gw_eff + + real :: v_kxw, rv_kxw, v_kxw2 + + + +!=========================================================================== + integer :: nwav, nazd, nst + real :: eff + + real :: zaz_fct, zms + real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real, allocatable :: zcosang(:), zsinang(:) + real, allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) + +! +! GW-eddy constants for wave-mode dissipation by background and stability of +! "final" flow after application of GW-effects +! + real, parameter :: iPr_pt = 0.5 + real, parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. + real, parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable + real, parameter :: ric =0.25 + real, parameter :: rimin = -10., prmin = 0.25 + real, parameter :: prmax = 4.0 +! + contains +!============================================================================ + subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + +! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & +! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) +! + implicit none +! +!input -control for solvers: +! nwaves, nazdir, nstoch, effac, do_physb, kxw +! +! + integer :: me, master, nwaves, nazdir, nstoch + real :: effac, kxw + logical :: do_physb + real :: dlzmet +! +!locals +! + integer :: inc, jk, jl, iazi +! + real :: zang, zang1, znorm + real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + real :: fpc, fpc_dc + real :: ae1,ae2 + if( nwaves == 0) then +! +! redefine from the deafault +! + nwav = incdim + nazd = iazidim + nst = 0 + eff = 1.0 + gw_eff = eff + else +! +! from input.nml +! + nwav = nwaves + nazd = nazdir + nst = nstoch + gw_eff = effac + endif + + + v_kxw = pi2/lhmet ; v_kxw2 = v_kxw*v_kxw + rv_kxw = 1./v_kxw + + allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) + allocate ( zcosang(nazd), zsinang(nazd) ) + allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) + + if (me == master) then + print *, 'ugwp_v1: init_gw_wmsdis_control ' +! + print *, 'ugwp_v1: WMS_DIS launch layer ', ilaunch + print *, 'ugwp_v1: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. + print *, 'ugwp_v1: WMS_DIS lhmet in km ' , lhmet*1.e-3 + endif + + zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. + +! +! set up azimuth directions and some trig factors +! +! + zang = pi2 / float(nazd) + +! get normalization factor to ensure that the same amount of momentum +! flux is directed (n,s,e,w) no mater how many azimuths are selected. +! + znorm = 0.0 + do iazi=1, nazd + zang1 = (iazi-1)*zang + zcosang(iazi) = cos(zang1) + zsinang(iazi) = sin(zang1) + znorm = znorm + abs(zcosang(iazi)) + enddo +! zaz_fct = 1.0 + zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums + +! define coordinate transform for "Ch" ....x = 1/c stretching transform +! ----------------------------------------------- +! +! x=1/Cphase transform +! see eq. 28-30 Scinocca 2003. x = 1/c stretching transform +! + zxmax = 1.0 / zcimin + zxmin = 1.0 / zcimax + zxran = zxmax - zxmin + zdx = zxran / real(nwav-1) ! dkz +! + ae1=zxran/zgam + zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. + zx2 = zxmin - zx1 + +! +! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform +! it represents additional "empirical" redistribution of "spectral" mode in C-space +! + zms = pi2 / lzstar + + do inc=1, nwav + ztx = real(inc-1)*zdx+zxmin + ae1 = (ztx-zxmin)/zgam + zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 + zci(inc) = 1.0 /zx ! + zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + enddo +! +! +! alternatuve lzmax-lzmin +! +! + dlzmet = (lzmax-lzmin)/ real(nwav-1) + do inc=1, nwav + lzmet(inc) = lzmin + (inc-1)*dlzmet + mkzmet(inc) = pi2/lzmet(inc) + zci(inc) =lzmet(inc)/(pi2/bnfix) + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + + enddo + + zdx = (zci(nwav)-zci(1))/ real(nwav-1) + + + if (me == master) then + print * + print *, 'ugwp_v0: zcimin=' , zcimin + print *, 'ugwp_v0: zcimax=' , zcimax + print *, 'ugwp_v0: zgam= ', zgam + print * + +! print *, ' ugwp_v1 nslope=', nslope + print * + print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) + print *, 'ugwp_v1: zcimax/zci=' , minval(zci) + print *, 'ugwp_v1: cd_crit=', ucrit + print *, 'ugwp_v1: launch_level', ilaunch + print *, ' ugwp_v1 lzstar=', lzstar + print *, ' ugwp_v1 nslope=', nslope + + print * + do inc=1, nwav + zdci(inc) = zdx + if (nslope == 1) fpc = bnfix4*zci(inc)/ (bnfix4+zci4(inc)) + if (nslope == 0) fpc = bnfix3*zci(inc)/ (bnfix3+zci3(inc)) + fpc_dc = fpc * zdci(inc) + write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) + enddo + endif + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) + + end subroutine initsolv_wmsdis +! +! make a list of all-initilized parameters needed for "gw_solver_wmsdis" +! + + end module ugwp_wmsdis_init_v1 +!========================================================================= +! +! work TODO for 2-extra WAM-solvers: +! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) +! +!========================================================================= + subroutine init_dspdis_v1 + implicit none + end subroutine init_dspdis_v1 + + subroutine init_adodis_v1 + implicit none + end subroutine init_adodis_v1 + diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 new file mode 100644 index 000000000..fd41d8175 --- /dev/null +++ b/physics/cires_ugwp_module_v1.F90 @@ -0,0 +1,672 @@ + +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 new file mode 100644 index 000000000..4b2a19884 --- /dev/null +++ b/physics/cires_ugwp_ngw_utils.F90 @@ -0,0 +1,73 @@ +module cires_ugwp_ngw_utils + + +contains + + + subroutine tau_limb_advance(me, master, im, levs, ddd, curdate, & + j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + + + + use machine, only : kind_phys + + use cires_ugwp_module_v1, only : ntau_d1y, ntau_d2t + use cires_ugwp_module_v1, only : ugwp_taulat, days_limb, tau_limb + +! use cires_ugwp_module, only : ugwp_qbolat, days_merra, pmb127, days_y4md, days_y4ddd +! use cires_ugwp_module, only : tau_qbo, stau_qbo, uqboe, u2 => uzmf_merra + + implicit none + + integer, intent(in) :: me, master, im, levs, ddd, curdate, kdt + integer, intent(in), dimension(im) :: j1_tau, j2_tau + + real , intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau + + real, intent(out) :: tau_sat(im) + + integer :: i, j1, j2, k, it1, it2, iday + real :: tem, tx1, tx2, w1, w2, day2, day1, ddx + integer :: yr1, yr2 +! + integer :: iqbo1=1 +! + + + + it1 = 2 + do iday=1, ntau_d2t + if (float(ddd) .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + stop + endif + w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) + tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) + tau_sat(i) = tx1*w1 + w2*tx2 + enddo + + if (me == master ) then + print*, maxval(tau_limb), minval(tau_limb), ' tau_limb ' + print*, ntau_d2t + print*, days_limb(1) , days_limb(ntau_d2t) , ddd, ' days-taulimb ' + print*, 'curdate ', curdate + print*, maxval(tau_sat), minval(tau_sat), ' tau_sat_fv3 ' + endif + return + + end subroutine tau_limb_advance + +end module cires_ugwp_ngw_utils diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 new file mode 100644 index 000000000..fd692a825 --- /dev/null +++ b/physics/cires_ugwp_orolm97_v1.F90 @@ -0,0 +1,1008 @@ +module cires_ugwp_orolm97_v1 + + +contains + + + + subroutine gwdps_oro_v1(im, km, imx, do_tofd, & + pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & + prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & + oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, & + grav, con_omega, rd, cpd, rv, pi, arad, fv, sgh30, & + dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & + cdmbgwd, me, master, rdxzb, & + zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & + dudt_mtb, dudt_ogw, dudt_tms) +!---------------------------------------- +! ugwp_v1: gwdps_oro_v1 following recent updates of Lott & Miller 1997 +! eventually will be replaced with more "advanced"LLWB +! and multi-wave solver that produce competitive FV3GFS-skills +! +! computation of kref for ogw + coorde diagnostics +! all constants/parameters inside cires_ugwp_initialize.f90 +!---------------------------------------- + + use machine , only : kind_phys + use ugwp_common_v1, only : dw2min, velmin + + use ugwp_oro_init_v1, only : rimin, ric, efmin, efmax , & + hpmax, hpmin, sigfaci => sigfac , & + dpmin, minwnd, hminmt, hncrit , & + rlolev, gmax, veleps, factop , & + frc, ce, ceofrc, frmax, cg, & + fdir, mdir, nwdir, & + cdmb, cleff, fcrit_gfs, fcrit_mtb, & + n_tofd, ze_tofd, ztop_tofd + + use cires_ugwp_module_v1, only : kxw, max_kdis, max_axyz + + use cires_orowam2017, only : oro_wam_2017 + + use cires_vert_orodis_v1, only : ugwp_tofd1d + + +! use sso_coorde, only : pgwd, pgwd4 +!---------------------------------------- + implicit none + real(kind=kind_phys), parameter :: pgwd=1, pgwd4= pgwd + real(kind=kind_phys), parameter :: sigfac = 3, sigfacs = 0.5 + character(len=8) :: strsolver='pss-1986' ! current operational solver or 'wam-2017' + real(kind=kind_phys) :: gammin = 0.00999999 + real(kind=kind_phys), parameter :: nhilmax = 25. + real(kind=kind_phys), parameter :: sso_min = 3000. + logical, parameter :: do_adjoro = .false. +!---------------------------------------- + + integer, intent(in) :: im, km, imx, kdt + integer, intent(in) :: me, master + logical, intent(in) :: do_tofd + + + + integer, intent(in) :: kpbl(im) ! index for the pbl top layer! + real(kind=kind_phys), intent(in) :: dtp ! time step + real(kind=kind_phys), intent(in) :: cdmbgwd(2) + + real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & + clx4(im,4), theta(im), sigmad(im), & + gammad(im), elvmaxd(im) + + real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, & + pi, arad, fv + real(kind=kind_phys), intent(in) :: sgh30(im) + real(kind=kind_phys), intent(in), dimension(im,km) :: & + u1, v1, t1, q1,del, prsl, prslk, zmet + + real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti + real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) + real(kind=kind_phys), intent(in) :: sparea(im) + +! +!output -phys-tend + real(kind=kind_phys),dimension(im,km),intent(out) :: & + pdvdt, pdudt, pkdis, pdtdt +! output - diag-coorde + real(kind=kind_phys),dimension(im,km),intent(out) :: & + dudt_mtb, dudt_ogw, dudt_tms +! + real(kind=kind_phys),dimension(im) :: rdxzb, zmtb, zogw , & + tau_ogw, tau_mtb, tau_tofd, dusfc, dvsfc + +! +!--------------------------------------------------------------------- +! # of permissible sub-grid orography hills for "any" resolution < 25 +! correction for "elliptical" hills based on shilmin-area =sgrid/25 +! 4.*gamma*b_ell*b_ell >= shilmin +! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min +! gamma_min = 1/4*shilmin/sso_min/sso_min +!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 +! 192: cdmbgwd = 0.5, 2.5 +! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km +! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin +!--------------------------------------------------------------------- +! +! locals SSO +! + real(kind=kind_phys) :: vsigma(im), vgamma(im) + + real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax +! real(kind=kind_phys) :: arhills(im) ! not used why do we need? + real(kind=kind_phys) :: xlingfs + +! +! locals mean flow ...etc +! + real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro + real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco +!mtb + real(kind=kind_phys), dimension(im) :: oa, clx , sigma, gamma, & + elvmax, wk + real(kind=kind_phys), dimension(im) :: pe, ek, up + + real(kind=kind_phys), dimension(im,km) :: db, ang, uds + + real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr + real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 + real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem +! +! tofd +! some constants now in "use ugwp_oro_init" + "use ugwp_common" +! +!================== + real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf + real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 + real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 + real(kind=kind_phys), dimension(km) :: up1, vp1, zpm + + real(kind=kind_phys),dimension(im, km) :: axtms, aytms +! +! ogw +! + logical icrilv(im) +! + real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & + roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 +! + real(kind=kind_phys) :: taup(im,km+1), taud(im,km) + real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis + + integer, dimension(im) :: kref, idxzb, ipt, kreflm, iwklm, iwk, izlow + +! +!check what we need +! + real(kind=kind_phys) :: bnv, fr, ri_gw, brvf + real(kind=kind_phys) :: tem, tem1, tem2, temc, temv + real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 + real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv + real(kind=kind_phys) :: scork, rscor, hd, fro, sira + real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk + + real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge + + real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 + real(kind=kind_phys) :: belps, aelps, nhills, selps + + real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: pi2, rdi, gor, grcp, gocp, gr2, bnv2min + +! +! various integers +! + integer :: kmm1, kmm2, lcap, lcapp1 + integer :: npt, kbps, kbpsp1,kbpsm1 + integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll + integer :: k_mtb, k_zlow, ktrial, klevm1 + integer :: i, j, k +! +! initialize gamma and sigma + gamma(:) = gammad(:) + sigma(:) = sigmad(:) +! + rcpdt = 1.0 / (cpd*dtp) + grav2 = grav + grav +! + rgrav = 1.0/grav + rcpd = 1.0/cpd + rcpd2 = 0.5/cpd + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + pi2 = 2.*pi + rdi = 1.0/rd + gor = grav/rd + grcp = grav*rcpd + gocp = grcp + gr2 = grav*gor + bnv2min = (pi2/1800.)*(pi2/1800.) +! +! mtb-blocking sigma_min and dxres => cires_initialize +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + + dxres = pi2*arad/float(imx) + hdxres = 0.5*dxres +! shilmin = sgrmin/nhilmax ! not used - moorthi + +! gammin = min(sso_min/dsmax, 1.) ! moorthi - with this results are not reproducible + gammin = min(sso_min/dxres, 1.) ! moorthi + +! sigmin = 2.*hpmin/dsmax !dxres ! moorthi - this will not reproduce + sigmin = 2.*hpmin/dxres !dxres + +! if (kdt == 1) then +! print *, sgrmax, sgrmin , ' min-max sparea ' +! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax +! print *, 'dxres/dsmax ', dxres, dsmax +! print *, ' shilmin gammin ', shilmin, gammin +! endif + + kxridge = float(imx)/arad * cdmbgwd(2) + + if (me == master .and. kdt == 1) then + print *, ' gwdps_v0 kxridge ', kxridge + print *, ' gwdps_v0 scale2 ', cdmbgwd(2) + print *, ' gwdps_v0 imx ', imx + print *, ' gwdps_v0 gam_min ', gammin + print *, ' gwdps_v0 sso_min ', sso_min + endif + + do i=1,im + idxzb(i) = 0 + zmtb(i) = 0.0 + zogw(i) = 0.0 + rdxzb(i) = 0.0 + tau_ogw(i) = 0.0 + tau_mtb(i) = 0.0 + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + tau_tofd(i) = 0.0 +! + ipt(i) = 0 +! + enddo + + do k=1,km + do i=1,im + pdvdt(i,k) = 0.0 + pdudt(i,k) = 0.0 + pdtdt(i,k) = 0.0 + pkdis(i,k) = 0.0 + dudt_mtb(i,k) = 0.0 + dudt_ogw(i,k) = 0.0 + dudt_tms(i,k) = 0.0 + enddo + enddo + +! ---- for lm and gwd calculation points +!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 +!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) +!---- for lm and gwd calculation points + + + npt = 0 + + do i = 1,im + if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then + npt = npt + 1 + ipt(npt) = i + endif + enddo + + if (npt == 0) then +! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt +! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin + return ! no gwd/mb calculation done + endif +!======================================================== + +! + if (do_adjoro ) then + + do i = 1,im +! arhills(i) = 1.0 +! + sigres = max(sigmin, sigma(i)) +! if (sigma(i) < sigmin) sigma(i)= sigmin + dxres = sqrt(sparea(i)) + if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres + aelps = min(2.*hprime(i)/sigres, 0.5*dxres) + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) +! +! small-scale "turbulent" oro-scales < sso_min +! + if( aelps < sso_min ) then + +! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm +! + aelps = sso_min + if (belps < sso_min ) then + gamma(i) = 1.0 + belps = aelps*gamma(i) + else + gamma(i) = min(aelps/belps, 1.0) + endif + + sigma(i) = 2.*hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + + endif + + selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill + nhills = min(nhilmax, sparea(i)/selps) +! arhills(i) = max(nhills, 1.0) + +!333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) +! if (kdt==1 ) +! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, +! & belps*1.e-3, sigma(i),gamma(i) + + + enddo + endif !(do_adjoro ) + + + + do i=1,npt + iwklm(i) = 2 + idxzb(i) = 0 + kreflm(i) = 0 + enddo + + do k=1,km + do i=1,im + db(i,k) = 0.0 + ang(i,k) = 0.0 + uds(i,k) = 0.0 + enddo + enddo + + kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 + lcap = km ; lcapp1 = lcap + 1 + + cdmb4 = 0.25*cdmb + + do i = 1, npt + j = ipt(i) + elvmax(j) = min (elvmaxd(j)*0. + sigfac * hprime(j), hncrit) + izlow(i) = 1 ! surface-level + enddo +! + do k = 1, kmm1 + do i = 1, npt + j = ipt(i) + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) +! if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) +! & iwklm(i) = max(iwklm(i), k+1 ) + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) iwklm(i) = max(iwklm(i), k+1 ) + if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) + + enddo + enddo +! + do k = 1,km + do i =1,npt + j = ipt(i) + vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) + vtk(i,k) = vtj(i,k) / prslk(j,k) + ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels + taup(i,k) = 0.0 + enddo + enddo +! +! check ri_n or ri_mf computation +! + do k = 1,kmm1 + do i =1,npt + j = ipt(i) + rdz = 1. / (zmet(j,k+1) - zmet(j,k)) + tem1 = u1(j,k) - u1(j,k+1) + tem2 = v1(j,k) - v1(j,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz +! ti = 2.0 / (t1(j,k)+t1(j,k+1)) +! bvf2 = grav*(gocp+rdz*(vtj(i,k+1)-vtj(i,k)))* ti +! ri_n(i,k) = max(bvf2/shr2,rimin) ! richardson number +! + bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! +! add here computation for ktur and ogw-dissipation fro ve-gfs +! + enddo + enddo + k = 1 + do i = 1, npt + bnv2(i,k) = bnv2(i,k+1) + enddo +! +! level iwklm => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) +! + do i = 1, npt + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == iwklm(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,iwklm(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,iwklm(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + pe (i) = 0.0 + ek (i) = 0.0 + bnv2bar(i) = 0.0 + enddo +! + do i = 1, npt + k_zlow = izlow(i) + if (k_zlow == iwklm(i)) k_zlow = 1 + do k = k_zlow, iwklm(i)-1 ! kreflm(i)= iwklm(i)-1 + j = ipt(i) ! laye-aver rho, u, v + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) ! trial mean u below + vbar(i) = vbar(i) + rdelks * v1(j,k) ! trial mean v below + roll(i) = roll(i) + rdelks * ro(i,k) ! trial mean ro below +! + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo + enddo +! + do i = 1, npt + j = ipt(i) +! +! integrate from ztoph = sigfac*hprime down to zblk if exists +! find ph_blk, dz_blk like in LM-97 and ifs +! + ph_blk =0. + do k = iwklm(i), 1, -1 + phiang = atan2(v1(j,k),u1(j,k))*rad_to_deg + ang(i,k) = ( theta(j) - phiang ) + if ( ang(i,k) > 90. ) ang(i,k) = ang(i,k) - 180. + if ( ang(i,k) < -90. ) ang(i,k) = ang(i,k) + 180. + ang(i,k) = ang(i,k) * deg_to_rad + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +! + if (idxzb(i) == 0 ) then + dz_blk = zmeti(j,k+1) - zmeti(j,k) + pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk + + up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) + ek(i) = 0.5 * up(i) * up(i) + + ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) + +! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs +! if ( pe(i) >= ek(i) ) then + if ( ph_blk >= fcrit_gfs ) then + idxzb(i) = k + zmtb (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif + + endif + enddo +! +! alternative expression: zmtb = max(heff*(1. -fcrit_gfs/fr), 0) +! fcrit_gfs/fr +! + goto 788 + + bnv = sqrt( bnv2bar(i) ) + heff = 2.*min(hprime(j),hpmax) + zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) + ulow(i) = sqrt(max(zw2,dw2min)) + fr = heff*bnv/ulow(i) + zw1 = max(heff*(1. -fcrit_gfs/fr), 0.0) + zw2 = zmet(j,2) + if (fr > fcrit_gfs .and. zw1 > zw2 ) then + do k=2, kmm1 + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) + if (zw1 <= zmetp .and. zw1 >= zmetk) exit + enddo + idxzb(i) = k + zmtb (j) = zmet(j, k) + else + zmtb (j) = 0. + idxzb(i) = 0 + endif + +788 continue +! +! --- the drag for mtn blocked flow +! + if ( idxzb(i) > 0 ) then + +! (4.16)-ifs + gam2 = gamma(j)*gamma(j) + bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 + cgam = 0.48*gamma(j) + 0.30*gam2 + + do k = idxzb(i)-1, 1, -1 + zlen = sqrt( (zmtb(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 +! +! cos =1 sin =0 => 1/r= gam zr = 2.-gam +! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam +! + rdem = cosang2 + gam2 * sinang2 + rnom = cosang2*gam2 + sinang2 +! +! metoffice dec 2010 +! correction of h. wells & a. zadra for the +! aspect ratio of the hill seen by mean flow +! (1/r , r-inverse below: 2-r) + + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + + sigres = max(sigmin, sigma(j)) + if (hprime(j)/sigres > dxres) sigres = hprime(j)/dxres + mtbridge = zr * sigres*zlen / hprime(j) +! (4.15)-ifs +! dbtmp = cdmb4 * mtbridge * & +! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) +! (4.16)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) + db(i,k)= dbtmp * uds(i,k) + enddo +! + endif + enddo +!............................. +!............................. +! end mtn blocking section +!............................. +!............................. +! +!--- orographic gravity wave drag section +! +! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 +! inside "cires_ugwp_initialize.f90" now +! + kmpbl = km / 2 + iwk(1:npt) = 2 +! +! meto/UK-scheme: +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw +! + do k=3,kmpbl + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb + +!=============================================================== +! lev=111 t=311.749 hkm=0.430522 ps-p(iwk)=52.8958 +! below "hprime" - source of ogws and below zblk !!! +! 27 2 kpbl ~ 1-2 km < hprime +!=============================================================== + enddo + enddo +! +! iwk - adhoc gfs-parameter to select ogw-launch level between +! level ~0.4-0.5 km from surface or/and pbl-top +! in ugwp-v1: options to modify as htop ~ (2-3)*hprime > zmtb +! in ugwp-v0 we ensured that : zogw > zmtb +! + + kbps = 1 + kmps = km + k_mtb = 1 + do i=1,npt + j = ipt(i) + k_mtb = max(1, idxzb(i)) + + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else ???? + kref(i) = max(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime + + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above zmtb + kbps = max(kbps, kref(i)) + kmps = min(kmps, kref(i)) +! + delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + bnv2bar(i)= 0.0 + enddo +! + kbpsp1 = kbps + 1 + kbpsm1 = kbps - 1 + k_mtb = 1 +! + do i = 1,npt + k_mtb = max(1, idxzb(i)) + do k = k_mtb,kbps !kbps = max(kref) ;kmps= min(kref) + if (k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref + vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref + roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo + enddo +! +! orographic asymmetry parameter (oa), and (clx) + do i = 1,npt + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) + clx(i) = clx4(j,mod(nwd-1,4)+1) + enddo +! + do i = 1,npt + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control vector + ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) + xn(i) = ubar(i) / ulow(i) + yn(i) = vbar(i) / ulow(i) + enddo +! + do k = 1, kmm1 + do i = 1,npt + j = ipt(i) + velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) + + enddo + enddo +! +!------------------ +! v0: incorporates latest modifications for kxridge and heff/hsat +! and taulin for fr <=fcrit_gfs +! and concept of "clipped" hill if zmtb > 0. to make +! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data +! it is still used the "single-orowave"-approach along ulow-upwind +! +! in contrast to the 2-orthogonal wave (2otw) schemes of ifs/meto/e-canada +! 2otw scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b +! with 2-stresses: taub_a & taub_b as of Phillips (1984) +!------------------ + taub(:) = 0. ; taulin(:)= 0. + do i = 1,npt + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + + if( zmtb(j) > 0.) heff = max(sigfac*heff-zmtb(j), 0.)/sigfac + if (heff <= 0) cycle + + hsat = fcrit_gfs*ulow(i)/bnv + heff = min(heff, hsat) + + fr = min(bnv * heff /ulow(i), frmax) +! + efact = (oa(i) + 2.) ** (ceofrc*fr) + efact = min( max(efact,efmin), efmax ) +! + coefm = (1. + clx(i)) ** (oa(i)+1.) +! + xlinv(i) = coefm * cleff ! effective kxw for lin-wave + xlingfs = coefm * cleff +! + tem = fr * fr * oc(j) + gfobnv = gmax * tem / ((tem + cg)*bnv) +! +!new specification of xlinv(i) & taulin(i) + + sigres = max(sigmin, sigma(j)) + if (heff/sigres > hdxres) sigres = heff/hdxres + inv_b2eff = 0.5*sigres/heff + kxridge = 1.0 / sqrt(sparea(j)) + xlinv(i) = xlingfs !or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge + taulin(i) = 0.5*roll(i)*xlinv(i)*bnv*ulow(i)*heff*heff*pgwd4 + + if ( fr > fcrit_gfs ) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact ! nonlinear flux tau0...xlinv(i) +! + else +! taub(i) = taulin(i) ! linear flux for fr <= fcrit_gfs + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact +! + endif +! +! + k = max(1, kref(i)-1) + tem = max(velco(i,k)*velco(i,k), dw2min) + scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level +! +! diagnostics for zogw > zmtb +! + zogw(j) = zmeti(j, kref(i) ) + enddo +! +!----set up bottom values of stress +! + do k = 1, kbps + do i = 1,npt + if (k <= kref(i)) taup(i,k) = taub(i) + enddo + enddo + + if (strsolver == 'pss-1986') then + +!====================================================== +! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" +! in v1-orogw linsatdis of "wam-2017" +! with llwb-mechanism for +! rotational/non-hydrostat ogws important for +! highres-fv3gfs with dx < 10 km +!====================================================== + + do k = kmps, kmm1 ! vertical level loop from min(kref) + kp1 = k + 1 + do i = 1, npt +! + if (k >= kref(i)) then + icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) + endif + enddo +! + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + temv = 1.0 / max(velco(i,k), velmin) +! + if (oa(i) > 0. .and. kp1 < kref(i)) then +! + scork = bnv2(i,k) * temv * temv + rscor = min(1.0, scork / scor(i)) + scor(i) = scork + else + rscor = 1. + endif +! + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface +! tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*velco(i,k)*0.5 + + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*0.5 & + * max(velco(i,k), velmin) + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv +! +! rim is the "wave"-richardson number by palmer,shutts, swinbank 1986 +! + + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check stability to employ the 'dynamical saturation hypothesis' +! of palmer,shutts, swinbank 1986 +! + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf + taup(i,kp1) = tem1 * hd * hd + else + taup(i,kp1) = taup(i,k) * rscor + endif +! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif + endif + enddo + enddo +! +! zero momentum deposition at the top model layer +! + taup(1:npt,km+1) = taup(1:npt,km) +! +! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud +! + do k = 1,km + do i = 1,npt + taud(i,k) = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) + enddo + enddo + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!------if the gravity wave drag would force a critical line in the +!------layers below sigma=rlolev during the next deltim timestep, +!------then only apply drag until that critical line is reached. +! empirical implementation of the llwb-mechanism: lower level wave breaking +! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb +! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws +!2019: this option limits sensitivity of taux/tauy to increase/decrease of taub +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then + + if(taud(i,k) /= 0.) then + tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +! dtfac(i) = 1.0 + endif + endif + enddo + enddo +! +!--------------------------- orogw-solver of gfs pss-1986 +! + else +! +!-----------Unified orogw-solver of wam2017 +! +! sigres = max(sigmin, sigma(j)) +! if (heff/sigres.gt.dxres) sigres=heff/dxres +! inv_b2eff = 0.5*sigres/heff +! xlinv(i) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./lridge + + dtfac(:) = 1.0 + + call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, con_omega, rd, & + del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) + + endif ! oro_wam_2017 - linsatdis-solver of wam-2017 +! +!---- above orogw-solver of wam2017 +! +! tofd as in beljaars-2004 +! +! --------------------------- + if( do_tofd ) then + axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 + if ( kdt == 1 .and. me == 0) then + print *, 'vay do_tofd from surface to ', ztop_tofd + endif + do i = 1,npt + j = ipt(i) + zpbl = zmet( j, kpbl(j) ) + + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso + + zsurf = zmeti(j,1) + do k=1,km + zpm(k) = zmet(j,k) + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo + + call ugwp_tofd1d(km, cpd, sigflt, elvmaxd(j), zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,km + axtms(j,k) = utofd1(k) + aytms(j,k) = vtofd1(k) +! +! add tofd to gw-tendencies +! + pdvdt(j,k) = pdvdt(j,k) + aytms(j,k) + pdudt(j,k) = pdudt(j,k) + axtms(j,k) + enddo +!2018-diag + tau_tofd(j) = sum( utofd1(1:km)* del(j,1:km)) + enddo + endif ! do_tofd + +!-------------------------------------------- +! combine oro-drag effects MB +TOFD + OGWs +!-------------------------------------------- +! + diag-3d + + dudt_tms = axtms + tau_ogw = 0. + tau_mtb = 0. + + do k = 1,km + do i = 1,npt + j = ipt(i) +! + eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) +! + if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then +! +! if blocking layers -- no ogws +! + dbim = db(i,k) / (1.+db(i,k)*dtp) + pdvdt(j,k) = - dbim * v1(j,k) +pdvdt(j,k) + pdudt(j,k) = - dbim * u1(j,k) +pdudt(j,k) + eng1 = eng0*(1.0-dbim*dtp)*(1.-dbim*dtp) + + dusfc(j) = dusfc(j) - dbim * u1(j,k) * del(j,k) + dvsfc(j) = dvsfc(j) - dbim * v1(j,k) * del(j,k) +!2018-diag + dudt_mtb(j,k) = -dbim * u1(j,k) + tau_mtb(j) = tau_mtb(j) + dudt_mtb(j,k)* del(j,k) + + else +! +! ogw-s above blocking height +! + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) * pgwd + dtauy = taud(i,k) * yn(i) * pgwd + + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) + + unew = u1(j,k) + dtaux*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + dtauy*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) +! + dusfc(j) = dusfc(j) + dtaux * del(j,k) + dvsfc(j) = dvsfc(j) + dtauy * del(j,k) +!2018-diag + dudt_ogw(j,k) = dtaux + tau_ogw(j) = tau_ogw(j) +dtaux*del(j,k) + endif +! +! local energy deposition sso-heat +! + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + enddo + enddo +! dusfc w/o tofd sign as in the era-i, merra and cfsr + do i = 1,npt + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) + tau_mtb(j) = -rgrav * tau_mtb(j) + tau_ogw(j) = -rgrav * tau_ogw(j) + tau_tofd(j) = -rgrav * tau_tofd(j) + enddo + + return + + +!============ debug ------------------------------------------------ + if (kdt <= 2 .and. me == 0) then + print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' +! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' + print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' + print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' +! print *, maxval(tau_tofd), ' tau_tofd ' +! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' +! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' + if (maxval(abs(pdudt))*86400. > 100.) then + + print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' + print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' + print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' + print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' + print *, maxval(del), minval(del), ' del gwdps-v0 ' + print *, maxval(zmet),minval(zmet), 'zmet' + print *, maxval(zmeti),minval(zmeti), 'zmeti' + print *, maxval(prsi), minval(prsi), ' prsi ' + print *, maxval(prsl), minval(prsl), ' prsl ' + print *, maxval(ro), minval(ro), ' ro-dens ' + print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' + print * + do i =1, npt + j= ipt(i) + print *,zogw(j)/hprime(j), zmtb(j)/hprime(j), & + zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) +! +!.................................................................... +! +! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m +! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km +! we must exclude blocking by small ridges +! vay-kref < iblk zogw-lev 15 block-level: 39 +! +! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters +! max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), minwnd) +! max(dw2,dw2min) * rdz * rdz +! ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) +! tem = max(velco(i,k)*velco(i,k), 0.1) +! temv = 1.0 / max(velco(i,k), 0.01) +! & * max(velco(i,k),0.01) +!.................................................................... + enddo + print * + stop + endif + endif + +!cires_ugwp_solv2_v1.f90 + return + end subroutine gwdps_oro_v1 + + +end module cires_ugwp_orolm97_v1 diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 new file mode 100644 index 000000000..46a5fb833 --- /dev/null +++ b/physics/cires_ugwp_solv2_v1_mod.F90 @@ -0,0 +1,829 @@ +module cires_ugwp_solv2_v1_mod + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- + subroutine cires_ugwp_solv2_v1(im, levs, dtp , & + tm , um, vm, qm, prsl, prsi, zmet, zmeti, & + prslk, xlatd, sinlat, coslat, & + grav, cpd, rd, rv, omega, pi, fv, & + pdudt, pdvdt, pdtdt, dked, tauabs, wrms, trms, & + tau_ngw, mpi_id, master, kdt) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! -------------------------------------------------------------------------------- +! + + use machine, only : kind_phys + + use cires_ugwp_module_v1,only : krad, kvg, kion, ktg + + use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use ugwp_common_v1 , only : dw2min, velmin, hpscale, rhp, rh4 +! + use ugwp_wmsdis_init_v1, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +!23456 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + + real ,intent(in) :: dtp ! model time step + real ,intent(in) :: vm(im,levs) ! meridional wind + real ,intent(in) :: um(im,levs) ! zonal wind + real ,intent(in) :: qm(im,levs) ! spec. humidity + real ,intent(in) :: tm(im,levs) ! kinetic temperature + + real ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real ,intent(in) :: prsi(im,levs+1) ! interface pressure + real ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real ,intent(in) :: xlatd(im) ! lat was in radians, now with xlat_d in degrees + real ,intent(in) :: sinlat(im) + real ,intent(in) :: coslat(im) + real ,intent(in) :: tau_ngw(im) + + integer, intent(in):: mpi_id, master, kdt + + real ,intent(in) :: grav, cpd, rd, rv, omega, pi, fv +! +! +! out-gw effects +! + real ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp + real ,intent(out) :: dked(im,levs) ! gw-eddy diffusion +! +! GW diagnostics => next move it to "module_gw_diag" +! + real ,intent(out) :: tauabs(im,levs) ! + real ,intent(out) :: wrms(im,levs) ! + real ,intent(out) :: trms(im,levs) ! + + real :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real :: fpu(nazd, levs+1) ! az-momentum flux + real :: ui(nazd, levs+1) ! azimuthal wind + + real :: fden_bn(levs+1) ! density/brent + real :: flux_z(nwav,levs+1) + real :: flux(nwav, nazd) +! +! =============================================================================================== +! ilaunch:levs ....... MOORTHI's improvements +! all computations of GW-effects include interface layers from ilaunch+1 to levs +1 +! at k=levs+1, extrapolation of MF-state has been made, "ideally" all spectral modes should +! be absorbed; 2-options for this "ideal" requirement +! a) properly truncate GW-spectra ; b) dissipate all GW-energy in the top layers ( GW-sponge) +!===================================================================================================== +! + real :: bn(levs+1) ! interface BV-frequency + real :: bn2(levs+1) ! interface BV*BV-frequency + real :: rhoint(levs+1) ! interface density + real :: uint(levs+1) ! interface zonal wind + real :: vint(levs+1) ! meridional wind + + real :: irhodz_mid(levs), dzdt(levs+1), bnk(levs+1), rhobnk(levs+1) + + real :: v_zmet(levs+1) + real :: vueff(levs+1) + real :: dfdz_v(nazd, levs) ! axj = -df*rho/dz directional momentum deposition + + + real :: suprf(levs+1) ! RF-super linear dissipation + + real, dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet + real, dimension(levs+1) :: aprsi, azmeti + + real :: wrk3(levs) + real, dimension(levs) :: uold, vold, told, unew, vnew, tnew + real, dimension(levs) :: dktur, rho, rhomid, adif, cdif + + real :: rdci(nwav), rci(nwav) + real :: wave_act(nwav, nazd) ! active waves at given vert-level + real :: ul(nazd) ! velocity in azimuthal direction at launch level + real :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real :: c2f2, cf1 + + + real :: flux_norm ! norm-factor + real :: taub_src, rho_src +! +! scalars +! + real :: zthm, dtau, cgz, ucrit_maxdc + real :: vm_zflx_mode, vc_zflx_mode + real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real :: ucrit_max + real :: pwrms, ptrms + real :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real :: zatmp, fluxs, zdep, ze1, ze2 +! + real :: rcpdl, grav2cpd, rcpd, rcpd2, pi2, rad_to_deg + real :: deg_to_rad, rdi, gor, grcp, gocp, bnv2min, bnv2max, gr2 + real :: grav2, rgrav, rgrav2, mkzmin, mkz2min +! + real :: zdelp, zdelm, taud_min + real :: tvc, tvm, ptc, ptm + real :: umfp, umfm, umfc, ucrit3 + real :: fmode, expdis, fdis + real :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real :: v_wdi, v_wdpc + real :: ugw, vgw, ek1, ek2, rdtp, rdtp2 + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + + real :: uz, vz, shr2 , ritur, ktur + + real :: kamp, zmetk, zgrow + real :: stab, stab_dt, dtstab + integer :: nstab, ist, anstab(levs) + real :: w1, w2, w3, dtdif + + real :: dzmetm, dzmetp, dzmetf, bdif, kturp + real :: bnrh_src +!-------------------------------------------------------------------------- +! + + if (mpi_id == master .and. kdt < 2) then + print *, im, levs, dtp, kdt, ' vay-solv2-v1' + print *, minval(tm), maxval(tm), ' min-max-tm ' + print *, minval(vm), maxval(vm), ' min-max-vm ' + print *, minval(um), maxval(um), ' min-max-um ' + print *, minval(qm), maxval(qm), ' min-max-qm ' + print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' + print *, minval(prsi), maxval(prsi), ' min-max-Pint ' + print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' + print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' + print *, minval(prslk), maxval(prslk), ' min-max-Exner ' + print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' + print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! + endif + + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + + + grav2 = grav + grav + rgrav = 1.0/grav + rgrav2 = rgrav*rgrav + rdi = 1.0/rd + gor = grav/rd + gr2 = grav*gor + rcpd = 1.0/cpd + rcpd2 = 0.5/cpd + rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + pi2 = 2.0*pi + grcp = grav*rcpd + gocp = grcp + grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + bnv2min = (pi2/1800.)*(pi2/1800.) + bnv2max = (pi2/30.)*(pi2/30.) + mkzmin = pi2/80.0e3 + mkz2min = mkzmin*mkzmin + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp +! +! launch level control ksrc > 2 +! + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + + jl =j + tx1 = 2*omega * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + taub_src = max(tau_ngw(jl), tau_min) + aum(km2:levs) = um(jl,km2:levs) + avm(km2:levs) = vm(jl,km2:levs) + atm(km2:levs) = tm(jl,km2:levs) + aqm(km2:levs) = qm(jl,km2:levs) + aprsl(km2:levs) = prsl(jl,km2:levs) + azmet(km2:levs) = zmet(jl,km2:levs) + aprsi(km2:levs+1) = prsi(jl,km2:levs+1) + azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk) * (1. +fv*aqm(jk)) + tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0 / (tvc+tvm) +! + uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) + vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = azmeti(jk+1)-azmeti(jk) ! >0 ...... dz-meters + zdelm = 1./(azmet(jk)-azmet(jk-1)) ! 1/dz ...... 1/meters + dzdt(jk) = dtp/zdelp +! +! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + bnk(jk) = bn(jk)*v_kxw + rhobnk(jk)=rhoint(jk)/bnk(jk)*v_kxw + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src + + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min)+kvg(k), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur*0. + 2.e-5*exp( zmetk) + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + suprf(ktop) = kion(jk) + + rhoint(ktop) = aprsi(ktop)*rdi/atm(jk) + + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) + bnk(ktop) = bn(ktop)*v_kxw + + rhobnk(ktop) = rhoint(ktop)/bnk(ktop)*v_kxw + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + bnrh_src = bvi/rhoint(ksrc) +! +! define intrinsic velocity (relative to ilaunch) u(z)-u(zo), and coefficinets +! ------------------------------------------------------------------------------------------ + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + do jk=ksrc, ktop + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1, ksrc) =0. + do inc=1,nwav + zcin = zci(inc) + zcin4 = zci4(inc)/bvi4 +! + if(nslope == 0) then + zcin3 = zci3(inc)/bvi3 + flux(inc,1) = zcin/(1.+zcin3) + endif + + if(nslope == 1) flux(inc,1) = zcin/(1.+zcin4) + if(nslope == 2) flux(inc,1)= zcin/(1.+zcin4*zcin*rcms) + +! integrate (flux x dx) + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) + + do iaz=1,nazd + akzw(inc, iaz,ksrc:ktop) = bvi*rci(inc) + enddo + + enddo +! + flux_norm = taub_src / fpu(1, ksrc) +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + enddo + +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + bnrh_src=bnrh_src*flux_norm + do jk=ksrc, ktop + fden_bn(jk) = bnrh_src*rhoint(jk) / bn(jk) !*bvi/rhoint(ksrc) + enddo + +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! copy flux-1 into other azimuths +! -------------------------------- + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! constant flux below ilaunch + do jk=km1, ksrc + do inc=1, nwav + flux_z(inc,jk)=flux(inc,1) + enddo + enddo + + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + do inc=1, nwav + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + + if (v_cdp .le. ucrit_max) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max ; wave's absorption +! + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/v_zmet(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + flux_z(inc,jkp) = fluxs +! ucrit_maxdc =0. + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + v_cdp2=v_cdp*v_cdp +! +! rotational cut-off +! + cdf2 = v_cdp2 - c2f2 + + if (cdf2 > 0.0) then + kzw2 = (bn2(jkp)-wdop2)/Cdf2 + else + kzw2 = mkz2min + endif + + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds = kxw*Cdf1*rhp2/kzw3 +! + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + supRF(jk) ! supRF - diss due to FRF-FV3dycore for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + endif + + fdis = fmode*expdis +! +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! fluxs= fden_bn(jkp)*cdf2*zcinc + fluxs= fden_bn(jkp)*sqrt(cdf2) + +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! + zdep = wave_act(inc,iaz)* (fdis-fluxs) + if(zdep > 0.0 ) then +! subs on sat-limit + flux(inc,iaz) = fluxs + flux_z(inc,jkp) = fluxs + else +! assign dis-ve flux + flux(inc,iaz) = fdis + flux_z(inc,jkp) = fdis + endif + +! cgz = bnk(jk)/max(mkz2min, kzw2) + + dtau = flux_z(inc,jk)-flux_z(inc,jkp) + if (dtau .lt. 0) flux_z(inc,jkp) = flux_z(inc,jk) + +! if (dtau .ge. ucrit_maxdc) then +! flux_z(inc,jkp) = max(flux_z(inc,jk)-ucrit_maxdc, 0.) +! ze1 = zci(inc)-umfc-ucrit_maxdc +! write(6,287) dzdt(jk)/cgz, dtau/ucrit_maxdc, flux_z(inc,jkp)*1.e3, fluxs*1.e3, jk, zci(inc), ze1 +! +! endif +! 287 format(' dtau >ucrit_max', 4(2x, F12.7), I4, 2x, 2(2x,F8.3)) +! + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 + + +! + enddo ! wave-inc-loop +! +! integrate over spectral modes fpu(y, z, azimuth) wave_act(jl,inc,iaz)*flux(jl,inc,iaz)*[d("zcinc")] +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. +! new arrays + + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + + + dfdz_v(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + fpu(iaz, jkp) = fpu(iaz,jkp) + vc_zflx_mode*zcinc + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + zdelp = wrk3(jk)*abs(zci(inc)-umfc) *zcinc + vm_zflx_mode = flux_z(inc,jk) + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) +(vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 + endif + enddo !waves inc=1,nwav + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! -------------- + enddo ! end Azimuth do-loop + +! +! extra- eddy wave dissipation to limit GW-rms +! tx1 = sum(abs(dfdz_v(jk,1:nazd)))/bn2(jk) +! ze1=max(dked_min, tx1) +! ze2=min(dked_max, ze1) +! vueff(jkp) = ze2 + vueff(jkp) +! + + + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! + fpu(1:nazd,ktop) = fpu(1:nazd, levs) + dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk)+ dfdz_v(iaz,jk) + enddo + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + + endif +! + + do jk=ksrc,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +! ek1 =aum(jk)*aum(jk) +avm(jk)*avm(jk) +! ugw = aum(jk)- ze1*dtp; vgw = avm(jk)- ze2*dtp +! ek2 = ugw*ugw +vgw*vgw +! pdtdt(jl,jk) = rdtp2*max(ek1-ek2, 0.0) !=ze1*um + 0.5*ze1^2*dtp +! pdtdt(jl,jk) = max(ze1*aum(jk) + ze2*avm(jk), 0.) ! gw_eff => in "ze1 and ze2" + pdtdt(jl,jk) = max(pdtdt(jl,jk) , 0.)*gw_eff + endif + + if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt + ze1 = max(dked_min, pdtdt(jl,jk)/bn2(jk)) + dked(jl,jk) = min(dked_max, ze1) + + enddo +! +! add limiters/efficiency for "unbalanced ics" if it is needed +! + do jk=ksrc,levs + pdtdt(jl,jk) = pdtdt(jl,jk)*rcpd + enddo +! + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, 3 + do jk=ksrc,levs-1 + adif(jk) = .25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + +! dked(jl, ksrc:levs-1) = dktur(ksrc:levs-1) +! dked(jl, levs) =dked(jl, levs-1) + +! +! perform "diffusive" 3-point smoothing of "u-v-t" +! from the surface to the "top" +! + if (knob_ugwp_dokdis == 2) then + + uold(1:levs) = aum(1:levs)+pdudt(jl,1:levs)*dtp + vold(1:levs) = avm(1:levs)+pdvdt(jl,1:levs)*dtp + told(1:levs) = atm(1:levs)+pdtdt(jl,1:levs)*dtp + + do jk=1,levs + zmetk= azmet(jk)*rhp + ktur = kvg(k) + 2.e-5*exp( zmetk) + dktur(jk) = dked(jl,jk) + ktur + enddo + + dzmetm= azmet(ksrc)- azmet(ksrc-1) + + do jk=2,levs-1 + dzmetf = (azmeti(jk+1)- azmeti(jk))*rhomid(jk) + ktur = .5*(dktur(jk-1)+dktur(jk)) *rhoint(jk)/dzmetf + kturp = .5*(dktur(jk+1)+dktur(jk))*rhoint(jk+1)/dzmetf + + dzmetp = azmet(jk+1)-azmet(jk) + Adif(jk) = ktur/dzmetm + Cdif(jk) = kturp/dzmetp + bdif = adif(jk)+cdif(jk) + if (rdtp < bdif ) then + Anstab(jk) = nint( bdif/rdtp + 1) + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + if (nstab .ge. 2) print *, 'nstab ', nstab + dtdif = dtp/real(nstab) + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = nstab*rdtp-Adif(k)-Cdif(k) + unew(k) = uold(k)*Bdif+ uold(k-1)*Adif(k) + uold(k)*Cdif(k) + vnew(k) = vold(k)*Bdif+ vold(k-1)*Adif(k) + vold(k)*Cdif(k) + tnew(k) = told(k)*Bdif+ told(k-1)*Adif(k) + told(k)*Cdif(k) + enddo + uold = unew*dtdif + vold = vnew*dtdif + told = tnew*dtdif + enddo +! +! create "smoothed" tendencies by molecular + GW-eddy diffusion +! + do k=ksrc,levs-1 + pdtdt(jl,jk)= rdtp*(told(k) - tm(jl,k)) + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 +! +! add eddy viscosity heating +! pdtdt(jl,jk) = pdtdt(jl,jk) - max(ze1*aum(jk) + ze2*avm(jk), 0.) *rcpd +! + enddo + + + ENDIF ! dissipative IF-loop for "abrupt" tendencies + + enddo ! J-loop +! + + + RETURN + +! +! Print/Debugging ----------------------------------------------------------------------- +! + 239 continue + if (kdt ==1 .and. mpi_id == master) then +! + print *, 'ugwp-vay: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwp-vay: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwp-vay: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwp-vay: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif + + + + return + end subroutine cires_ugwp_solv2_v1 + + +end module cires_ugwp_solv2_v1_mod diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 new file mode 100644 index 000000000..8cfd57cb7 --- /dev/null +++ b/physics/cires_ugwp_triggers_v1.F90 @@ -0,0 +1,584 @@ +module cires_ugwp_triggers_v1 + + +contains + + + subroutine ugwp_triggers + implicit none + write(6,*) ' physics-based triggers for UGWP ' + end subroutine ugwp_triggers +! + SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, earth_r, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + implicit none + integer :: nx, ny + real :: lon(nx), lat(ny) + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + real :: ra1, ra2, dx, dy, dlat + real :: con_pi, earth_r + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + integer :: j + real :: deg_to_rad +! +! specify common constants and +! geometric factors to compute deriv-es etc ... +! coriolis coslat tan etc... +! + deg_to_rad = con_pi/180.0 + ra1 = 1.0 / earth_r + ra2 = ra1*ra1 +! + rlat = lat*deg_to_rad + rlon = lon*deg_to_rad + tanlat = atan(rlat) + cosv = cos(rlat) + dy = rlat(2)-rlat(1) + dx = rlon(2)-rlon(1) +! + do j=1, ny-1 + rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) + enddo +! + do j=2, ny-1 + brcos(j) = 1.0 / cos(rlat(j))*ra1 + enddo + + brcos(1) = brcos(2) + brcos(ny) = brcos(ny-1) + brcos2 = brcos*brcos +! + dlam1 = brcos / (dx+dx) + dlam2 = brcos2 / (dx*dx) + + dlat = ra1 / (dy+dy) + + divJp = dlat*cosv + divJM = dlat*cosv +! + do j=2, ny-1 + divJp(j) = dlat*cosv(j+1)/cosv(j) + divJM(j) = dlat*cosv(j-1)/cosv(j) + enddo + divJp(1) = divjp(2) !*divjp(1)/divjp(2) + divJp(ny) = divjp(1) + divJM(1) = divjM(2) !*divjM(1)/divjM(2) + divJM(ny) = divjM(1) +! + return + end SUBROUTINE subs_diag_geo +! + subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! compute for each Vert-column: grad(V) +! periodic in X and central diff ... +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Vx(nx, ny), Vy(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) + + end subroutine get_xy_pt + + subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) +! +! compute for each Vert-column: grad(V) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + implicit none + integer :: nx, ny + real :: V(nx, ny), dlam1(ny), dlat + real :: Divjp(ny), Divjm(ny) + real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) + integer :: i, j + do i=2, nx-1 + Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) + enddo + Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) + Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) + + do j=2, ny-1 + Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) + enddo + Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) + Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) +!~~~~~~~~~~~~~~~~~~~~ +! 1/cos*d(vcos)/dy +!~~~~~~~~~~~~~~~~~~~~ + do j=2, ny-1 + Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) + enddo + Vyd(:, 1) = Vyd(:,2) + Vyd(:,ny) = Vyd(:,ny-1) + + end subroutine get_xyd_wind + + subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & + con_pi, con_rerth, pmid, trig3d_fgf) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) + real :: con_pi, con_rerth +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_fgf +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + + enddo + end subroutine trig3d_fjets + + subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) + real :: con_pi, con_rerth +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_okw +! +! locals +! + real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty + integer :: k, i, j + + real, parameter :: cappa=2./7., pref=1.e5 + real, dimension(nx, ny) :: pt, w1, w2, d1 + + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) + + real :: dx, dy, dlat + real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) + + call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & + cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) + + do k=1, nz + w1(:,:) = P3d(:,:,k) + w2(:,:) = T(:,:,k) + + pt = w2*(pref/w1)**cappa + call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) + w1(:,:) = V(:,:, K) + call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) + w1(:,:) = U(:,:, K) + call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) + + trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty + w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 + W2 = (Vx - Uyd)*(Vx - Uyd) + D1 = Ux + Vyd + trig3d_okw(:,:,k) = W1 -W2 +! trig3d_okw(:, :, k) =S2 -W2 +! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean +! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk + enddo + end subroutine trig3d_okubo +! + subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS + real, dimension(nx, ny, nz) :: trig3d_conv + + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + integer :: k + end subroutine trig3d_dconv + + subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & + U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & + con_pi, con_rerth, trig3d_okw, trig3d_fgf, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) + + implicit none + integer :: nx, ny, nz + real :: lon(nx), lat(ny) + real :: con_pi, con_rerth +! +! reversed ??? Hyai, Hybi , pmid +! + real, dimension(nz+2) :: Hyai, Hybi + real, dimension(nz+1) :: Hyam, Hybm +! + real, dimension(nz) :: pmid + real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d + real, dimension(nx, ny ) :: PS, HS + real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv + real, dimension(nx, ny, nz) :: dcheat3d, scheat3d + real, dimension(nx, ny ) :: precip2d + integer,dimension(nx, ny, 3 ):: cld_klevs2d + real :: dzkm, zkm + integer :: k +!================================================================================== +! fgf and OW-triggers +! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! +! +!=================================================================================== + + call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & + con_pi, con_rerth, pmid, trig3d_fgf) + call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) + call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & + dcheat3d, precip2d, cld_klevs2d, scheat3d) +!===================================================================================================== +! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d +! +! Bulk momentum flux=/ 0 and levels for launches +! +!===================================================================================================== + 111 format(i6, 4(3x, F8.3), ' trigger-grid ') + + do k=1, nz-1 + zkm = -7.*alog(pmid(k)*1.e-3) + dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) + write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' + enddo + + end subroutine cires_3d_triggers +!================================================================================== +! tot-flux launch 0 or 1 # of Launches +! specify time-dep bulk sources: taub, klev, if_src, nf_src +! +!================================================================================== + subroutine get_spectra_tau_convgw & + (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) +! +! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function +! + integer :: nw, im, levs + integer,dimension(im,3) :: icld + real, dimension(im, levs) :: dcheat, scheat + real, dimension(im) :: precip, xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real, parameter :: precip_max = 100. ! mm/day + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + + integer :: i, k, klow, ktop, kmid + real :: dtot, dmax, daver +! + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + do i=1, im + klow = icld(i,1) + ktop = icld(i,2) + kmid= icld(i,3) + if (klow == -99 .and. ktop == -99) then + cycle + else + klev(i) = ktop + k = klow + klev(i) = k + dmax = abs(dcheat(i,k) + scheat(i,k)) + do k=klow+1, ktop + dtot =abs(dcheat(i,k) + scheat(i,k)) + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! +! klev as max( dcheat(i,k) + scheat) +! vertical width of conv-heating +! +! counts/triiger=1 & taub(i) +! + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_amp* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! 100 mb launch and MERRA-2 slat-forcing +! + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo + +! with info on precip/clouds/dc_heat create Bulk +! taub(im), klev(im) +! +! print *, ' get_spectra_tau_convgw ' + end subroutine get_spectra_tau_convgw +! + subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_fgf +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1.0 / float(kwidth) + tau_min = tau_amp*fnorm + do i=1, im +! +! only trop-c fjets so find max(trig_fgf) => klev +! use abs-values to scale tau_amp +! + + k = klow + klev(i) = k + dmax = abs(trig_fgf(i,k)) + kex = 0 + if (dmax >= tlim_fgf) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_fgf(i,k)) + if (dtot >= tlim_fgf) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo + + if (dmax .ge. tlim_fgf) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! print *, ' get_spectra_tau_nstgw ' + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo +! + end subroutine get_spectra_tau_nstgw +! + subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real, dimension(im, levs) :: trig_okw +! real, dimension(im, levs+1) :: pint + real, dimension(im) :: xlatd, sinlat, coslat + real, dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real, parameter :: tau_amp = 35.e-3 ! 35 mPa + real, parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real :: dtot, dmax, daver + real :: fnorm, tau_min + + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1./float(kwidth) + tau_min = tau_amp*fnorm + print *, ' get_spectra_tau_okwgw ' + do i=1, im + k = klow + klev(i) = k + dmax = abs(trig_okw(i,k)) + kex = 0 + if (dmax >= tlim_okw) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_okw(i,k)) + if (dtot >= tlim_fgf ) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! + if (dmax >= tlim_okw) then + nf_src = nf_src + 1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo + print *, ' get_spectra_tau_okwgw ' + end subroutine get_spectra_tau_okw +! +! +! +!>\ingroup cires_ugwp_run +!> @{ +!! +!! + subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: tau_amp, xlatdeg(im), tau_gw(im) + real :: latdeg, flat_gw, tem + integer :: i + +! +! if-lat +! + do i=1, im + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = 0.10 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_tamp_v1 + + subroutine slat_geos5(im, xlatdeg, tau_gw) +!================= +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real :: xlatdeg(im) + real :: tau_gw(im) + real :: latdeg + real, parameter :: tau_amp = 100.e-3 + real :: trop_gw, flat_gw + integer :: i +! +! if-lat +! + trop_gw = 0.75 + do i=1, im + latdeg = xlatdeg(i) + if (-15.3 < latdeg .and. latdeg < 15.3) then + flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) + if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw + else if (latdeg > -31. .and. latdeg <= -15.3) then + flat_gw = 0.10 + else if (latdeg < 31. .and. latdeg >= 15.3) then + flat_gw = 0.10 + else if (latdeg > -60. .and. latdeg <= -31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg < 60. .and. latdeg >= 31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg <= -60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + else if (latdeg >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + end if + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5 + subroutine init_nazdir(con_pi, naz, xaz, yaz) + implicit none + real :: con_pi + integer :: naz + real, dimension(naz) :: xaz, yaz + integer :: idir + real :: phic, drad + real :: pi2 + pi2 = 2.0*con_pi + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir + + +end module cires_ugwp_triggers_v1 + diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 new file mode 100644 index 000000000..852c114b0 --- /dev/null +++ b/physics/cires_vert_orodis_v1.F90 @@ -0,0 +1,1047 @@ +module cires_vert_orodis_v1 + + +contains + + +! subroutine ugwp_drag_mtb +! subroutine ugwp_taub_oro +! subroutine ugwp_oro_lsatdis +! + subroutine ugwp_drag_mtb( iemax, nz, & + elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & + up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) + + use ugwp_common_v1, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi + use ugwp_oro_init_v1, only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver + + implicit none +!======================== +! several versions for drmtb => high froude mountain blocking +! version 1 => vay_2018 ; +! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 +! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 +!======================== +! real, parameter :: Fcrit_mtb = 0.7 + + integer, intent(in) :: nz + integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime + real , intent(out) :: taumtb + + integer , intent(out) :: idxzb + real, dimension(nz), intent(out) :: drmtb + + real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) + real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam + real, intent(in) :: zpbl + + real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid + real, dimension(nz+1), intent(in) :: zpi, pint + + ! character(len=*), intent(out) :: errmsg + ! integer, intent(out) :: errflg +! + real, dimension(nz+1) :: zpi_zero + real, dimension(nz) :: zpm_zero + real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp + + real, dimension(nz) :: bn2, uds, umf, cosang, sinang + + integer :: k, klow, ktop, kpbl + real :: uhm, vhm, bn2hm, rhohm, & + mtb_fix, umag, bnmag, frd_src, & + zblk, who_iz_normal, rlm97, & + phiang, ang, pe, ek, & + cang, sang, ss2, cs2, zlen, dbtmp, & + hamp, bgamm, cgamm + + + ! Initialize CCPP error handling variables + ! errmsg = '' + ! errflg = 0 + +!================================================== +! +! elvp + hprime <=>elvp + nridge*hprime, ns =2 +! ns = sigfac +! tau_parel & tau_normal along major "axes" +! +! options to block the "flow", choices for [klow, ktop] +! +! 1-directional (normal) & 2-directional "blocking" +! +!================================================== +! no - blocking: drmtb(1:nz) = 0.0 +!================= + idxzb = -1 + drmtb(1:nz) = 0.0 + taumtb = 0.0 + klow = 2 + + ktop = iemax + hamp = nridge*hprime + +! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime + + mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp + + ! if (mtb_fix == 0.) then + ! write(errmsg,'(*(a))') cdmb, sigma, hamp, ' MTB == 0' + ! errflg = 1 + ! return + ! endif + + if (strver == 'vay_2018') then + + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + + do k=1, nz-1 + if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then + ktop = k+1 !......simply k+1 next interface level + exit + endif + enddo +! print *, klow, ktop, ' klow-ktop ' + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s + ! if (bn2hm .le. 0.0) then + ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' + ! errflg = 1 + ! return ! unstable PBL + ! end if + + bnmag =sqrt(bn2hm) + + frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. + +! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' +! + if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking +! +! zblk > 0 +! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk +! + zblk = hamp*(1. - Fcrit_mtb/frd_src) + idxzb =1 + do k = 2, ktop + + if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then + idxzb = k + exit + endif + enddo +! + if (idxzb == 1) RETURN ! first surface level block is not "important" + + if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 +! +! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 +! + bgamm = 1.0 - 0.18*gam -0.04*gam*gam + cgamm = 0.48*gam +0.3*gam*gam + + do k = 1, idxzb-1 + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + + umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + + phiang = atan(vp(k)/umag) +! theta -90/90 + ang = theta - phiang + cang = cos(ang) ; sang = sin(ang) + + who_iz_normal = max(cang, gam*sang ) !gfs-2018 + + cs2 = cang* cang ; ss2 = 1.-cs2 + + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it +! + if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level +! + + who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS + + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + if (dbtmp < 0) dbtmp = 0.0 +! +! several approximation can be made to implement MTB-drag +! as a "nonlinear level dependent"-drag or "constant"-drag +! uds(k) == umag = const between the 1-layer and idxzb +! + + drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u + taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! +! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used +! with Umag-projections on A & B ellipse axes +! mtb_fix =0.25*cdmb*sigma/hprime, +! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. +! +!333 format(i4, 7(2x, F10.3)) +! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 + enddo +! + endif + endif ! strver=='vay_2018' +! +! +! + if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then + + print *, ' kdn_2005 with # of hills ' +! +! compute flow-blocking stress based on WRF 'gwdo2d' +! + endif +! +! + if (strver == 'gfs_2018') then + + ktop = iemax; klow = 2 + + call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + if (bn2hm <= 0.0) RETURN ! unstable PBL +!--------------------------------------------- +! +!'gfs_2018' .... does not rely on Fr_crit +! and Fr-regimes +!----gfs17 for mtn ignores "averaging of the flow" +! for MTB-part it is only works with "angles" +! no projections on [uhm, vhm] -direction +! kpbl can be used for getting high values of iemax-hill +!----------------------------------------------------------- + zpm_zero = zpm - zpi(1) + zpi_zero = zpi - zpi(1) + do k=1, nz-1 + if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then + kpbl = k+1 + exit + endif + enddo + + do k = iemax, 1, -1 + + uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) + phiang = atan(vp(k)/uds(k)) + ang = theta - phiang + cosang(k) = cos(ang) + sinang(k) = sin(ang) + + if (idxzb == 0) then + pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) + umf(k) = uds(k) * cosang(k) ! normal to main axis + ek = 0.5 * umf(k) * umf(k) +! +! --- dividing stream lime is found when pe =>exceeds ek first from the "top" +! + if (pe >= ek) idxzb = k + exit + endif + enddo + +! idxzb = min(kpbl, idxzb) +! +! +! +! last: mtb-drag +! + if (idxzb > 1) then + zblk = zpm(idxzb) + print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) + do k = idxzb-1, 1, -1 +! + zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) + cs2 = cosang(k)* cosang(k) + ss2 = 1.-cs2 + rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it + + who_iz_normal = max(cosang(k), gam*sinang(k)) +! +! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) +! + dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal + + drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u +! + taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) +! + enddo + endif + endif ! strver=='gfs17' +! +! + end subroutine ugwp_drag_mtb +! +! +! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] +! +! + subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & + hprime , sigma, theta, oc, oa4, clx4, gamm, & + elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & + tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) +! + use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin + use ugwp_common_v1, only : mkz2min, mkzmin + use cires_ugwp_module_v1, only : frcrit, ricrit, linsat + use ugwp_oro_init_v1, only : hpmax, cleff, frmax + use ugwp_oro_init_v1, only : nwdir, mdir, fdir + use ugwp_oro_init_v1, only : efmin, efmax , gmax, cg, ceofrc + use ugwp_oro_init_v1, only : fcrit_sm, fcrit_gfs, frmin, frmax + use ugwp_oro_init_v1, only : coro, nridge, odmin, odmax + use ugwp_oro_init_v1, only : strver +! + use ugwp_oro_init_v1, only : zbr_pi +! --- +! +! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) +! approximate for drlee-momentum tendency +! --- + implicit none +! + integer, intent(in) :: levs, izb + real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero + integer, intent(out) :: kdswj, krefj, kotr + integer :: klwb + real, intent(in) :: kxw, fcor + real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp + +! + real, intent(in) :: oa4(4), clx4(4) + + real, dimension(levs), intent(in) :: up, vp, tp, qp, dp + real, dimension(levs+1), intent(in) :: zpi, pint + real, dimension(levs ), intent(in) :: zpm, pmid +! + real,dimension(levs), intent(out) :: drlee + real,dimension(levs+1), intent(out) :: tau_src +! + real, intent(out) :: tauogw, tautot, taulee + real :: taulin, tauhcr, taumtb + real, intent(out) :: xn, yn, umag, kxridge +! +! +! locals +! four possible versions to compute "taubase as a function of Fr-number" +! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' +! + real, dimension(levs+1) :: zpi_zero + + real :: oa, clx, odir, cl4p(4), clxp + + real :: uhm, vhm, bn2hm, rhohm, bnv + + real :: elvpMTB, wdir + real :: tem, efact, coefm, kxlinv, gfobnv + + real :: fr, frlin, frlin2, frlin3, frlocal, dfr + real :: betamax, betaf, frlwb, frmtb + integer :: klow, ktop, kph + + integer :: i, j, k, nwd, ind4, idir + + real :: sg_ridge, kx2, umd2 + real :: mkz, mkz2, zbr_mkz, mkzi + + real :: hamp ! clipped hprime*elvmax/elv_clip > hprime + real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) + real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves + real :: hcrit + real :: hblk ! blocking div-stream height + + real :: coef_h2, frnorm + + + real, dimension(levs) :: bn2 + real :: rho(levs) + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + real, dimension(levs+1) :: umd, phmkz + real :: c2f2, umag2, dzwidth, udir + real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp + real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms + real, dimension(levs+1) :: dtrans, deff + real :: pdtrans + logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 + logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum + ! between ZMTB => ZHILL +!----------------------------------------------------------------------------- +! +! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) +! ZMTB < ZOGW = ns*HPRIME < ELVP +! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB +! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new +! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW +! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB +! +!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] +! can be based on numerical runs like WRF-model +! for Frc < Fr< [Frc : 2.5-3 Frc] +! see suggestions proposed in SM-2000 and Eckermann et al. (2010) +!----------------------------------------------------------------------------- + tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 + krefj = 1 ; kotr = levs+1; kdswj = 1 + xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw + + dtrans = 0. ; deff =0. + klow = 2 + elvpMTB = elvp +! +! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB +! + if (izb > 0 ) then + klow = izb + elvpMTB = max(elvp - zpi(izb), 0.0) + endif + if (elvpMTB <=0 ) print *, ' blocked flow ' + if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX + + zpi_zero(:) = zpi(:) - zpi(1) + hblk = zpi_zero(klow) + + sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) + +! +! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp +! + sg_ridge = min(sg_ridge, hpmax) + +! print *, 'sg_ridge ', sg_ridge + + do k=1, levs + if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then + ktop = k+1 + exit + endif + enddo + + krefj = ktop ! the mountain top index for sg_ridge = ns*hprime + +! if ( izb > 0 .and. krefj .le. izb) then +! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' +! endif + +! +! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L +! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution +! + call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & + bn2, uhm, vhm, bn2hm, rhohm) + + call get_unit_vector(uhm, vhm, xn, yn, umag) + + if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment + bnv = sqrt(bn2hm) + hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer + hogw = hamp + hdsw = hamp + + + fr = bnv * hamp /umag + fr = min(fr, frmax) + kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx + kx2 = kxridge*kxridge + umag = max( umag, velmin) + c2f2 = fcor*fcor/kx2 + umag2 = umag*umag - c2f2 + + if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx + + mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" + ! and non-stationary waves coro, fcor for small umag + ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg + IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN +! +! case then no effects of wave-orography +! + krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 + tautot = 0. + tauogw = 0. + taulee = 0. + drlee = 0. ; tau_src(1:levs+1) = 0. + return + ENDIF +!========================================================================= +! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! make sure that SM_00 and KD_05 oro-characteristics can match each other +! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime +! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] +! alph-SM00 fraction of h2d contributed to hprime [0:1] +! +! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] +! delt-SM00 dw/up asymmetry -1 < delta < 1 +! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 +!.. +!A parametrization of low-level wave breaking which includes a dependence on +!the degree of 2-dimensionality of SG; it is active over a finite range of Fr +!========================================================================= + wdir = atan2(uhm,vhm) + pi + idir = mod( int(fdir*wdir),mdir) + 1 + + nwd = nwdir(idir) + ind4 = mod(nwd-1,4) + 1 + if (ind4 < 1 ) ind4 = 1 + if (ind4 > 4 ) ind4 = 4 + + oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) + clx = clx4(ind4) + cl4p(1) = clx4(2) + cl4p(2) = clx4(1) + cl4p(3) = clx4(4) + cl4p(4) = clx4(3) + clxp = cl4p(ind4) + + odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" + + odir = min(odmax, odir) + odir = max(odmin, odir) + + + if (strver == 'smc_2000' .or. strver == 'vay_2018') then +!========================================================================= +! +! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb +! taulin/tauogw taulee taumtb +! here tau_src(levs+1): approximate wave flux from surface to LLWB +! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) +!========================================================================= +! +! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 +! wave flux ~ rho_src*kx_src/mkz_src*wind_rms +! bn2, uhm, vhm, bn2hm, rhohm +! +! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN +! +! wave regimes +! + mkz = sqrt(mkz2) + frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb + frlin = fcrit_sm + frlin2 = 1.5*fcrit_sm + frlin3 = 3.0*fcrit_sm + + hcrit = fcrit_sm*umag/bnv + hogw = min(hamp, hcrit) + hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution + + coef_h2 = kxridge * rhohm * bnv * umag + + taulin = coef_h2 * hamp*hamp + tauhcr = coef_h2 * hcrit*hcrit + + IF (fr < frlin ) then + tauogw = taulin + taulee = 0.0 + taumtb = 0.0 + else if (fr .ge. frlin ) then + tauogw = tauhcr + taulin = coef_h2 * hamp*hamp + taumtb = tau_izb ! integrated form MTB +! +! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? +! + frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] + BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] + + if ( fr <= frlin2 ) then + Betaf= 2.*BetaMax*(frNorm-1.0) + taulee = (1. + Betaf )*taulin - tauhcr + else if ( (fr > frlin2).and.(fr <= frlin3))then + Betaf=-1.+ 1./frnorm/frnorm + & + (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) + taulee = (1. + Betaf )*taulin - tauhcr +!============== +! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) +! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) +! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) +! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) +! +!============== + else + taulee = 0.0 + hdsw = 0.0 + endif + ENDIF + + tautot = tauogw + taulee + taumtb*0. + + IF (taulee > 0.0 ) THEN + + hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge +! +! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves +! make "empirical" height above elvp that may represent DSW-wave breaking & trapping +! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge +! + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) ! kph marks the low-level of wave solutions + klwb = kph ! klwb above blocking marks wave-breaking + kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level + + if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) + + udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) + hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) + umd(krefj) = udir + + udir = max(ui(kph)*xn +vi(kph)*yn, velmin) + hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) + umd(kph) = udir + ! what we can put between k =[kph:krefj] + phmkz(:) = 0.0 ! + phmkz(kph-1) = fr ! initial Phase of the low-level wave +! +! now transfer tau_layer => tau_level assuming tau_layer = tau_level +! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT +! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 +! + loop_lwb_otr: do k=kph+1, krefj ! levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, dw2min) -c2f2 + + + if (umd2 <= 0.0) then +! +! critical layer +! + klwb = k + kotr = k + exit loop_lwb_otr + endif + + mkz2 = bn2i(k)/umd2 - kx2 + + if ( mkz2 >= mkz2min ) then +! +! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 +! at finest vertical resolution we can meet "abrupt" mkz +! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km +! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) +! + mkz = sqrt(mkz2) + hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) + udswz = hdswz *bn2i(k) +!=========================================================================================== +!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 +! +! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz +! by k = krefj tautot = tauogw(krefj) +!=========================================================================================== + if (do_klwb_phase) then + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then + klwb = min(k, krefj) + exit loop_lwb_otr + endif + endif + else ! mkz2 < mkz2min + kotr = k ! trapped/reflected waves / + exit loop_lwb_otr + endif + enddo loop_lwb_otr +! +! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee +! tau_trapped ??? +! + if (do_klwb_phase) then + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif +! +! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) +! more complicated is dissipative saturation pdtrans =/= constant +! + if (do_dtrans) then + do k=kph, krefj + tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) + drlee(k) = -tau_src(k)/rho(k) * pdtrans + enddo + endif + + + ENDIF !taulee > 0.0 + + + endif !strver +! + +!========================================================================= + if (strver == 'gfs_2018' .or. strver == 'kd_2005') then +!========================================================================= +! +! orowaves: OGW+DSW/Lee +! + efact = (oa + 2.0) ** (ceofrc*fr) + efact = min( max(efact,efmin), efmax ) + coefm = (1. + clx) ** (oa+1.) + + kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx + kxlinv = coefm * cleff + tem = fr * fr * oc + gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 +!========================================================================= +! source fluxes: taulin, taufrb +!========================================================================= + tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact + + coef_h2 = kxlinv *rhohm * bnv*umag + taulin = coef_h2 *hamp*hamp + hcrit = fcrit_gfs*umag/bnv + tauhcr = coef_h2 *hcrit*hcrit + + IF (fr <= fcrit_gfs) then + tauogw = taulin + tautot = taulin + taulee = 0. + drlee(:) = 0. + ELSE !fr > fcrit_gfs + tauogw = tauhcr + taulee = max(tautot - tauogw, 0.0) + if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) +! approximate drlee(k) between [izb, klwb] +! find klwb and decrease taulee(izb) => taulee(klwb) = 0. +! above izb tau + if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then + + mkz = sqrt(mkz2) + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) + + kph = max(izb, 2) + phmkz(:) = 0.0 + klwb = max(izb, 1) + kotr = levs+1 + phmkz(kph-1) = fr ! initial Phase of the Lee-OGW + + loop_lwb_gfs18: do k=kph, levs + + umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) + umd2 =(coro- umd(k))*(coro- umd(k)) + umd2 = max(umd2, velmin*velmin) + mkz2 = bn2i(k)/umd2 - kx2 + if ( mkz2 > mkz2min ) then + mkz = sqrt(mkz2) + frlocal = max(hdsw*bvi(k)/umd(k), frlwb) + phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) + if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k + else + kotr = k + exit loop_lwb_gfs18 + endif + enddo loop_lwb_gfs18 +! +! + do k=kph, kotr-1 + + if (klwb > kph .and. k < klwb) then + drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) + tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) + drlee(k) = drlee(k)/rho(k) + else if ( k >= klwb .and. k < kotr) then + tau_src(k) = tauogw + drlee(k) = 0.0 + endif + enddo + kdswj = klwb ! assign to the "low-level" wave breaking + endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 + ENDIF !fr > fcrit_gfs + + + ENDIF !strbase='gfs2017' .or. strbase='kd_2005' + + +! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge +! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' +! + end subroutine ugwp_taub_oro +! +!-------------------------------------- +! +! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, & +! con_pi, con_g, kxw, fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, & +! pmid1, pint1, xn, yn, umag, drtau, kdis_oro) + + subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & + pi, grav, kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, xn, yn, umag, drtau, kdis) + + use ugwp_common_v1, only : dw2min, velmin + use cires_ugwp_module_v1, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 + use cires_ugwp_module_v1, only : kvg, ktg, krad, kion + use ugwp_oro_init_v1, only : coro , fcrit_sm , fcrit_sm2 + implicit none +! + integer, intent(in) :: krefj, levs + real , intent(in) :: tauogw, tautot, kxw + real , intent(in) :: fcor + + real , dimension(levs+1) :: tau_src + + real, intent(in) :: pi, grav + + real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm + real, dimension(levs+1), intent(in) :: zpi, pmid, pint + real , intent(in) :: xn, yn, umag + real , intent(in) :: kxridge + + + real, dimension(levs), intent(out) :: drtau, kdis +! +! locals +! + real :: bnv2min, pi2, rgrav + real :: uref, udir, uf2, ufd, uf2p + real, dimension(levs+1) :: tauz + real, dimension(levs) :: rho + real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi + + integer :: i, j, k, kcrit, kref + real :: kx2, kx2w, kxs + real :: mkzm, mkz, dkz, mkz2, ch, kzw3 + real :: wfdM, wfdT, wfiM, wfiT + real :: fdis, mkzi, keff_m, keff_t + real :: betadis, betam, betat, cdfm, cdft + real :: fsat, hsat, hsat2, kds , c2f2 + + pi2 = 2.0*pi + bnv2min = (pi2/1800.)*(pi2/1800.) + rgrav = 1.0/grav + + drtau(1:levs) = 0.0 + kdis (1:levs) = 0.0 + + ch = coro + + kx2w = kxw*kxw + kx2 = kxridge*kxridge + if( kx2 < kx2w ) kx2 = kx2w + kxs = sqrt(kx2) + c2f2 = fcor*fcor/kx2 +! +! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) +! +! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' + call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & + pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) +!=============================================================================== +! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 +! rotational/non-hyrostatic effects are important only for high-res runs +! Udir = 0, Udir < 0 are not +! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz +! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) +! stochastic "tauogw'-setup+ sigma_tau ; +! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves +! target is to get "multiple"-saturation levels for OGWs +!=============================================================================== + tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode + ! sign of tauz > 0...and its attenuate with Z + k = krefj + uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves + uf2 = uref*uref - c2f2 + if (uf2 > 0) then + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2.gt.0) then + mkzm = sqrt(mkz2) + else + return ! wave reflection mkz2 <=0. + endif + else + return ! wave absorption uf2 <= 0. + endif +! +! upward solver for single "mode" with tauz(levs+1) =0. at the top +! + kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer + kcrit = levs + do k= krefj+1, levs +! +! 2D-wave propagation along reference-wind direction +! udir = 0 critical wind for coro =0 +! cdop = -uref .... upwind waves travel against MF +! + udir = ui(k)*xn +vi(k)*yn + uf2 = udir*udir - c2f2 + + + if (uf2 < dw2min .or. udir <= 0.0) then + kcrit =K + tauz(kcrit:levs) = 0. + exit ! vert-level loop + endif +! +! wave-based solution +! + mkz2 = bn2i(k)/uf2 -kx2 + if (mkz2 > 0) then + mkzm = sqrt(mkz2) +! +! do dissipative flux vs saturation: kvg, ktg, krad, kion +! + kzw3 = mkzm*mkz2 +! + keff_m = kvg(k)*mkz2 + kion(k) +! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol + keff_t = ktg(k)*mkz2 + krad(k) +! +! + uf2p = uf2 + 2.0*c2f2 + betadis = uf2/uf2p + betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw + betaT = 1.0- BetaM + +! +!imaginary frequencies of momentum and heat with "kds at (k-1) level" +! + wfiM = kds*mkz2 + keff_m + wfiT = kds*mkz2 + keff_t +! + cdfm = sqrt(uf2)*kxs + cdft = abs(udir)*kxs + wfdM = wfiM/cdfm *BetaM + wfdT = wfiT/Cdft *BetaT + mkzi = 2.0*mkzm*(wfdM+wfdT) + + fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) + tauz(k) = fdis + hsat2 = fcrit_sm2 * uf2 *bn2i(k) + fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) + if (fdis > fsat) then + tauz(k) = min(fsat, tauz(k-1)) +!================================================================= +! two definitions for eddy mixing of MF: +! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 +! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 +!================================================================= + kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) + kdis(k) = kds + endif + else + tauz(k:levs) = 0. ! wave is reflected above + kds = 0. + endif + enddo + + do k=krefj+1, kcrit + drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) + enddo +! +! + end subroutine ugwp_oro_lsatdis +! +! + subroutine ugwp_tofd(im, levs, con_cp, sigflt, elvmax, zpbl, u, v, zmid, & + utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none +! + integer :: im, levs + real(kind_phys) :: con_cp + real(kind_phys), dimension(im, levs) :: u, v, zmid + real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl + real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: rcpd2 + real :: sgh = 30. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp +! + + do i=1, im + + zdec = max(n_tofd*sigflt(i), zpbl(i)) + zdec = min(ze_tofd, zdec) + rzdec = 1.0/zdec + sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) + + do k=1, levs + zmet = zmid(i,k) + if (zmet > ztop_tofd) cycle + ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) + umag = sqrt(ekin) + zarg = zmet*rzdec + zexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp + utofd(i,k) = -krf*u(i,k) + vtofd(i,k) = -krf*v(i,k) + epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re + krf_tofd(i,k) = krf + enddo + enddo +! + end subroutine ugwp_tofd +! +! + subroutine ugwp_tofd1d(levs, con_cp, sigflt, elvmax, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! + implicit none + integer :: levs + real(kind_phys) :: con_cp + real(kind_phys), dimension(levs) :: u, v, zmid + real(kind_phys) :: sigflt, elvmax, zpbl, zsurf + real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd +! +! locals +! + integer :: i, k + real :: rcpd2 + real :: sghmax = 5. + real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed 18 km + rzdec = 1.0/zdec + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + ekin = u(k)*u(k) + v(k)*v(k) + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf + enddo +! + end subroutine ugwp_tofd1d + + +end module cires_vert_orodis_v1 diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 4afad80d1..a07523342 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -338,6 +338,7 @@ subroutine cu_gf_deep_run( & integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers + real(kind=kind_phys) :: c0 ! HCB ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -383,6 +384,14 @@ subroutine cu_gf_deep_run( & ! sas ! lambau=0. ! pgcon=-.55 +! +!---------------------------------------------------- ! HCB +! Set cloud water to rain water conversion rate (c0) + c0=0.004 + if(imid.eq.1)then + c0=0.002 + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ztexec(:) = 0. zqexec(:) = 0. @@ -937,14 +946,14 @@ subroutine cu_gf_deep_run( & if(imid.eq.1)then call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) else call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) @@ -1266,14 +1275,14 @@ subroutine cu_gf_deep_run( & ! if(imid.eq.1)then ! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & ! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & ! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & ! 1,itf,ktf, & ! its,ite, kts,kte) ! else ! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & ! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & ! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & ! 1,itf,ktf, & ! its,ite, kts,kte) @@ -3865,7 +3874,7 @@ end subroutine cup_output_ens_3d !>\ingroup cu_gf_deep_group subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & - q,gamma_cup,zu,qes_cup,k22,qe_cup, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & zqexec,ccn,rho,c1d,t, & up_massentr,up_massdetr,psum,psumh, & itest,itf,ktf, & @@ -3904,6 +3913,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 + real(kind=kind_phys), intent (in ) :: & ! HCB + c0 ! ! input and output ! @@ -3944,7 +3955,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer :: start_level(its:ite) real(kind=kind_phys) :: & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & - c0,dz,berryc0,q1,berryc + dz,berryc0,q1,berryc real(kind=kind_phys) :: & denom, c0t real(kind=kind_phys), dimension (kts:kte) :: & @@ -3952,7 +3963,6 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! prop_b(kts:kte)=0 iall=0 - c0=.002 clwdet=50. bdsp=bdispm ! @@ -3999,7 +4009,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & enddo do 100 i=its,itf - c0=.004 + !c0=.004 HCB tuning if(ierr(i).eq.0)then ! below lfc, but maybe above lcl @@ -4031,8 +4041,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! do k=kbcon(i)+1,ktop(i) - c0=.004 - if(t(i,k).lt.270.)c0=.002 + !c0=.004 HCB tuning + !if(t(i,k).lt.270.)c0=.002 HCB tuning if(t(i,k) > 273.16) then c0t = c0 else diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 8e81cf8ab..dcf0d183b 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -185,10 +185,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & real(kind=kind_phys), dimension (im) :: hfx,qfx real(kind=kind_phys) tem,tem1,tf,tcr,tcrf - parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) - !parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim, HCB tuning ! initialize ccpp error handling variables errmsg = '' errflg = 0 diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 61d07382d..fc9aacabd 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3217,3 +3217,44 @@ @inproceedings{yudin_et_al_2019 Booktitle = {Space Weather Workshop}, Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, Year = {2019}} + +@article{kim_and_doyle_2005, + Author = {Y.-J. Kim and J.D. Arakawa}, + Doi = {10.1256/qj.04.160}, + Url = {https://doi.org/10.1256/qj.04.160}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1893-1921}, + Title = {Extension of an orographic-drag parametrization scheme to incorporate orographic inisotropy and flow blocking}, + Volume = {131}, + Year = {2005}} + +@article{steeneveld_et_al_2008, + Author = {Steeneveld, G. J.,A.A. M. Holtslag, C. J. Nappo, B. J. H. van de Wiel, and L. Mahrt}, + Doi = {10.1175/2008JAMC1816.1}, + Url = {https://doi.org/10.1175/2008JAMC1816.1}, + Journal = {J. Appl. Meteor.}, + Pages = {2518-2530}, + Title = {Exploring the possible role of small-scale terrain drag on stable boundary layers over land}, + Volume = {47}, + Year = {2008}} + +@article{tsiringakis_et_al_2017, + Author = {Tsiringakis,A., G. J. Steeneveld, and A.A. M. Holtslag}, + Doi = {10.1002/qj.3021}, + Url = {https://doi.org/10.1002/qj.3021}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1504-1516}, + Title = {Small-scale orographic gravity wave drag in stable boundary layers and its impact on synoptic systems and near-surface meteorology}, + Volume = {143}, + Year = {2017}} + +@article{beljaars_et_al_2004, + Author = {Beljaars, A.C.M., A.R.Brown, and N.Wood}, + Doi = {10.1256/qj.03.73}, + Url = {https://doi.org/10.1256/qj.03.73}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Pages = {1327-1347}, + Title = {A new parametrization of turbulent orographic form drag}, + Volume = {130}, + Year = {2004}} + diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 66bf7fcb5..eaa1366a8 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -184,13 +184,6 @@ end subroutine drag_suite_init !! !> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm !> @{ -! subroutine drag_suite_run( & -! & IM,IX,KM,A,B,C,U1,V1,T1,Q1,KPBL, & -! & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & -! & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & -! & DUSFC,DVSFC,G, CP, RD, RV, IMX, & -! & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, errmsg, errflg) -! subroutine drag_suite_run( & & IM,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & @@ -204,7 +197,9 @@ subroutine drag_suite_run( & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & - & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + & lprnt, ipr, rdxzb, dx, gwd_opt, & + & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + & errmsg, errflg ) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -241,6 +236,15 @@ subroutine drag_suite_run( & ! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating ! gsd_diss_ht_opt = 0: dissipation heating off ! gsd_diss_ht_opt = 1: dissipation heating on +! 2020-08-25 Michael Toy changed logic control for drag component selection +! for CCPP. +! Namelist options: +! do_gsl_drag_ls_bl - logical flag for large-scale GWD + blocking +! do_gsl_drag_ss - logical flag for small-scale GWD +! do_gsl_drag_tofd - logical flag for turbulent form drag +! Compile-time options (same as before): +! gwd_opt_ls = 0 or 1: large-scale GWD +! gwd_opt_bl = 0 or 1: blocking drag ! ! References: ! Hong et al. (2008), wea. and forecasting @@ -361,12 +365,16 @@ subroutine drag_suite_run( & !------------------------------------------------------------------------- ! Flags to regulate the activation of specific components of drag suite: ! Each component is tapered off automatically as a function of dx, so best to -! keep them activated (=1). - integer, parameter :: & - gwd_opt_ls = 1, & ! large-scale gravity wave drag - gwd_opt_bl = 1, & ! blocking drag - gwd_opt_ss = 1, & ! small-scale gravity wave drag (Steeneveld et al. 2008) - gwd_opt_fd = 1, & ! form drag (Beljaars et al. 2004, QJRMS) +! keep them activated (.true.). + logical, intent(in) :: & + do_gsl_drag_ls_bl, & ! large-scale gravity wave drag and blocking + do_gsl_drag_ss, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + do_gsl_drag_tofd ! form drag (Beljaars et al. 2004, QJRMS) + +! Additional flags + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag gsd_diss_ht_opt = 0 ! Parameters for bounding the scale-adaptive variability: @@ -614,7 +622,7 @@ subroutine drag_suite_run( & enddo enddo ! - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do i = its,im dusfc_ls(i) = 0.0 dvsfc_ls(i) = 0.0 @@ -757,7 +765,8 @@ subroutine drag_suite_run( & ! ! END INITIALIZATION; BEGIN GWD CALCULATIONS: ! -IF ( ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & +IF ( (do_gsl_drag_ls_bl).and. & + ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & (ls_taper .GT. 1.E-02) ) THEN !==== ! !--- saving richardson number in usqj for migwdi @@ -893,7 +902,7 @@ subroutine drag_suite_run( & endif enddo -ENDIF ! (gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1) +ENDIF ! (do_gsl_drag_ls_bl).and.((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) !========================================================= ! add small-scale wavedrag for stable boundary layer @@ -905,7 +914,7 @@ subroutine drag_suite_run( & utendwave=0. vtendwave=0. ! - IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + IF ( (do_gsl_drag_ss).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running small-scale gravity wave drag" ! ! declaring potential temperature @@ -1006,7 +1015,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) @@ -1017,12 +1026,12 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_ss == 1 +ENDIF ! if (do_gsl_drag_ss) !================================================================ ! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): !================================================================ -IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_tofd).and.(ss_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running form drag" utendform=0. @@ -1064,7 +1073,7 @@ subroutine drag_suite_run( & dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) enddo enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_fd(i,k) = utendform(i,k) @@ -1075,10 +1084,11 @@ subroutine drag_suite_run( & enddo endif -ENDIF ! end if gwd_opt_fd == 1 +ENDIF ! if (do_gsl_drag_tofd) !======================================================= ! More for the large-scale gwd component -IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl).and. & + (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running large-scale gravity wave drag" ! ! now compute vertical structure of the stress. @@ -1146,7 +1156,8 @@ subroutine drag_suite_run( & !=============================================================== !COMPUTE BLOCKING COMPONENT !=============================================================== -IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! if (me==master) print *,"in Drag Suite: Running blocking drag" do i = its,im @@ -1192,7 +1203,8 @@ subroutine drag_suite_run( & ENDIF ! end blocking drag !=========================================================== -IF ( (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN ! ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy ! @@ -1262,7 +1274,7 @@ subroutine drag_suite_run( & dvsfc(i) = (-1./g*rcs) * dvsfc(i) enddo - if (gwd_opt == 33) then + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then do k = kts,km do i = its,im dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) @@ -1277,9 +1289,9 @@ subroutine drag_suite_run( & enddo endif -ENDIF +ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls.EQ.1 .OR. gwd_opt_bl.EQ.1) -if (gwd_opt == 33) then +if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then ! Finalize dusfc and dvsfc diagnostics do i = its,im dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index f78259e82..fa5b317fc 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -591,6 +591,30 @@ type = integer intent = in optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 8b3555826..2125e0ad2 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -57,9 +57,9 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) ABSFCS (Model%nx*Model%ny), & ALFFC1 (Model%nx*Model%ny*2), & ALBFC1 (Model%nx*Model%ny*4), & - SMCFC1 (Model%nx*Model%ny*Model%lsoil), & - STCFC1 (Model%nx*Model%ny*Model%lsoil), & - SLCFC1 (Model%nx*Model%ny*Model%lsoil) + SMCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)), & + STCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)), & + SLCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)) logical :: lake(Model%nx*Model%ny) @@ -140,10 +140,16 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) ALBFC1 (len + npts*2) = Sfcprop(nb)%alnsf (ix) ALBFC1 (len + npts*3) = Sfcprop(nb)%alnwf (ix) - do ls = 1,Model%lsoil - SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) - STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) - SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + do ls = 1,max(Model%lsoil,Model%lsoil_lsm) + if (Model%lsoil == Model%lsoil_lsm) then + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + else + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smois (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%tslb (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%sh2o (ix,ls) + endif enddo IF (SLIFCS(len) < 0.1_kind_phys .OR. SLIFCS(len) > 1.5_kind_phys) THEN @@ -182,7 +188,7 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) rewind (Model%nlunit) endif #endif - CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & + CALL SFCCYCLE (9998, npts, max(Model%lsoil,Model%lsoil_lsm), SIG1T, Model%fhcyc, & Model%idate(4), Model%idate(2), & Model%idate(3), Model%idate(1), & Model%phour, RLA, RLO, SLMASK, & @@ -252,11 +258,17 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%alvwf (ix) = ALBFC1 (len + npts ) Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) - do ls = 1,Model%lsoil + do ls = 1,max(Model%lsoil,Model%lsoil_lsm) ll = len + (ls-1)*npts - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (ll) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (ll) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) + if(Model%lsoil == Model%lsoil_lsm) then + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (ll) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (ll) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) + else + Sfcprop(nb)%smois (ix,ls) = SMCFC1 (ll) + Sfcprop(nb)%tslb (ix,ls) = STCFC1 (ll) + Sfcprop(nb)%sh2o (ix,ls) = SLCFC1 (ll) + endif if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) enddo ENDDO !-----END BLOCK SIZE LOOP-------------------------- diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 496db7580..7cc64bbcf 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -5,12 +5,16 @@ MODULE mynnsfc_wrapper USE module_sf_mynn + !Global variables: + INTEGER, PARAMETER :: psi_opt = 0 !0: MYNN + !1: GFS + contains - subroutine mynnsfc_wrapper_init () + subroutine mynnsfc_wrapper_init() ! initialize tables for psih and psim (stable and unstable) - CALL PSI_INIT + CALL PSI_INIT(psi_opt) end subroutine mynnsfc_wrapper_init @@ -100,10 +104,10 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & spp_pbl = 0, & - & isftcflx = 0, & - & iz0tlnd = 0, & + INTEGER, PARAMETER :: & + & spp_pbl = 0, & + & isftcflx = 0, & !control: 0 + & iz0tlnd = 0, & !control: 0 & isfflx = 1 integer, intent(in) :: ivegsrc @@ -166,7 +170,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & lh, wstar !LOCAL real, dimension(im) :: & - & hfx, znt, ts, psim, psih, & + & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & & cpm, qgh, qfx @@ -199,14 +203,11 @@ SUBROUTINE mynnsfc_wrapper_run( & xland(i)=2.0 endif qgh(i)=0.0 + mavail(i)=1.0 !snowh(i)=snowd(i)*800. !mm -> m !znt_lnd(i)=znt_lnd(i)*0.01 !cm -> m !znt_ocn(i)=znt_ocn(i)*0.01 !cm -> m !znt_ice(i)=znt_ice(i)*0.01 !cm -> m - ! DH* do the following line only if wet(i)? - ts(i)=tskin_ocn(i)/exner(i,1) !theta - ! *DH - mavail(i)=1.0 !???? cpm(i)=cp enddo @@ -251,7 +252,8 @@ SUBROUTINE mynnsfc_wrapper_run( & CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & EP1=ep_1,EP2=ep_2,KARMAN=karman, & - ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,iz0tlnd=iz0tlnd, & + ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm, & + iz0tlnd=iz0tlnd,psi_opt=psi_opt, & & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) & z0pert=z0pert,ztpert=ztpert, & !intent(in) & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 7d449473b..c19b594dd 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1,12 +1,6 @@ !>\file module_mp_thompson.F90 !! This file contains the entity of GSD Thompson MP scheme. -! DH* 2020-06-05 -! Use the following preprocessor directive to roll back -! to the WRFv3.8.1, used in RAPv5/HRRRv4 for more reasonable -! representation of mesoscale storms and reflectivity values -!#define WRF381 - !>\ingroup aathompson !! This module computes the moisture tendencies of water vapor, @@ -463,13 +457,6 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & if (.NOT. ALLOCATED(tcg_racg) ) then ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) micro_init = .TRUE. - if (mpirank==mpiroot) then -#ifdef WRF381 - write(0,*) "Using Thompson MP from WRFv3.8.1 (RAPv5/HRRRv4)" -#else - write(0,*) "Using Thompson MP from WRFv4.0+" -#endif - endif endif if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) @@ -2716,13 +2703,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! supersat again. sump = pri_inu(k) + pri_ide(k) + prs_ide(k) & + prs_sde(k) + prg_gde(k) + pri_iha(k) -! DH* 2020-06-02 I believe that the WRF381 version -! is wrong, because the units do not match. -#ifdef WRF381 - rate_max = (qv(k)-qvsi(k))*odts*0.999 -#else rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 -#endif if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then ratio = rate_max/sump @@ -3599,7 +3580,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo -#ifdef WRF381 +#if 1 if (rr(kts).gt.R1*10.) & #else if (rr(kts).gt.R1*1000.) & @@ -3654,7 +3635,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo -#ifdef WRF381 +#if 1 if (ri(kts).gt.R1*10.) & #else if (ri(kts).gt.R1*1000.) & @@ -3685,7 +3666,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo -#ifdef WRF381 +#if 1 if (rs(kts).gt.R1*10.) & #else if (rs(kts).gt.R1*1000.) & @@ -3716,7 +3697,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo -#ifdef WRF381 +#if 1 if (rg(kts).gt.R1*10.) & #else if (rg(kts).gt.R1*1000.) & @@ -3761,21 +3742,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) -! DH* 2020-06-05 I believe WRF381 is wrong in terms of units; -! dividing by rho turns number concentration per volume into -! number concentration per mass. -#ifdef WRF381 nwfa1d(k) = MAX(11.1E6/rho(k), MIN(9999.E6/rho(k), & (nwfa1d(k)+nwfaten(k)*DT))) nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6/rho(k), & (nifa1d(k)+nifaten(k)*DT))) -#else - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & - (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & - (nifa1d(k)+nifaten(k)*DT))) -#endif - if (qc1d(k) .le. R1) then qc1d(k) = 0.0 nc1d(k) = 0.0 @@ -5276,31 +5246,14 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & ! are consistent with the WRFv3.8.1 settings, but inconsistent ! with the WRFv4+ settings. In order to apply the same bounds ! as before this change, use the WRF v3.8.1 settings throughout. -#if 1 -!ifdef WRF381 re_qc1d(:) = 2.50E-6 ! 2.49E-6 re_qi1d(:) = 5.00E-6 ! 4.99E-6 re_qs1d(:) = 1.00E-5 ! 9.99E-6 -#else - re_qc1d(:) = 2.49E-6 - re_qi1d(:) = 2.49E-6 - re_qs1d(:) = 4.99E-6 -#endif do k = kts, kte rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) rc(k) = MAX(R1, qc1d(k)*rho(k)) -#ifdef WRF381 - nc(k) = MAX(R2, MIN(nc1d(k)*rho(k), Nt_c_max)) -#else - ! DH* 2020-06-05 is using 2.0 instead of R2 - ! a bug in the WRFv4.0+ version of Thompson? - ! For ni(k) a few lines below, it is still R2. - ! Note that R2 is defined as R2 = 1.E-6, and is - ! used in other parts of Thompson MP for ni/nr - ! calculations (but not for nc calculations) nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) -#endif if (.NOT. is_aerosol_aware) nc(k) = Nt_c if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. ri(k) = MAX(R1, qi1d(k)*rho(k)) @@ -5329,12 +5282,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi -#if 1 -!ifdef WRF381 re_qi1d(k) = MAX(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#else - re_qi1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#endif enddo endif @@ -5374,12 +5322,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) smoc = a_ * smo2**b_ -#if 1 -!ifdef WRF381 re_qs1d(k) = MAX(1.01E-5, MIN(0.5*(smoc/smob), 999.E-6)) -#else - re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) -#endif enddo endif diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 94b118521..ebbc3dcf9 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -7,7 +7,7 @@ MODULE module_sf_mynn !------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES +!Modifications implemented by Joseph Olson NOAA/GSL !The following overviews the current state of this scheme:: ! ! BOTH LAND AND WATER: @@ -129,11 +129,13 @@ MODULE module_sf_mynn !! and Grachev et al (2000) for unstable conditions and the form !! from Cheng and Brutsaert (2005) for stable conditions. - SUBROUTINE mynn_sf_init_driver(allowed_to_read) + SUBROUTINE mynn_sf_init_driver(allowed_to_read,psi_opt) LOGICAL, INTENT(in) :: allowed_to_read + INTEGER, INTENT(IN) :: psi_opt - CALL psi_init + !CALL psi_init + CALL psi_init(psi_opt) END SUBROUTINE mynn_sf_init_driver @@ -146,7 +148,7 @@ SUBROUTINE SFCLAY_mynn( & PSFCPA,PBLH,MAVAIL,XLAND,DX, & !in CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in - ISFFLX,isftcflx,lsm,iz0tlnd, & !in + ISFFLX,isftcflx,lsm,iz0tlnd,psi_opt, & !in & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) @@ -285,7 +287,7 @@ SUBROUTINE SFCLAY_mynn( & !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl + INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -297,7 +299,7 @@ SUBROUTINE SFCLAY_mynn( & !=================================== ! 3D VARIABLES !=================================== - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + REAL, DIMENSION( ims:ime, kms:kme ) , & INTENT(IN ) :: dz8w, & QV3D, & P3D, & @@ -306,24 +308,24 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D, & th3d,pi3d - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, & + REAL, DIMENSION( ims:ime, kms:kme), OPTIONAL, & INTENT(IN) :: pattern_spp_pbl !=================================== ! 2D VARIABLES !=================================== - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 - REAL, DIMENSION( ims:ime, jms:jme ) , & + REAL, DIMENSION( ims:ime ) , & INTENT(INOUT) :: HFLX,HFX, & QFLX,QFX, & LH, & @@ -369,7 +371,7 @@ SUBROUTINE SFCLAY_mynn( & !ADDITIONAL OUTPUT !JOE-begin - REAL, DIMENSION( ims:ime, jms:jme ) :: qstar + REAL, DIMENSION( ims:ime ) :: qstar !JOE-end !=================================== ! 1D LOCAL ARRAYS @@ -384,7 +386,7 @@ SUBROUTINE SFCLAY_mynn( & REAL, DIMENSION( its:ite ) :: rstoch1D - INTEGER :: I,J,K,itf,jtf,ktf + INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- IF (debug_code >= 1) THEN @@ -397,100 +399,91 @@ SUBROUTINE SFCLAY_mynn( & ENDIF itf=ite !MIN0(ite,ide-1) - jtf=jte !MIN0(jte,jde-1) ktf=kte !MIN0(kte,kde-1) - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,kts,j) - dz2w1d(I) = dz8w(i,kts+1,j) - U1D(i) =U3D(i,kts,j) - V1D(i) =V3D(i,kts,j) - !2nd model level winds - for diags with high-res grids - U1D2(i) =U3D(i,kts+1,j) - V1D2(i) =V3D(i,kts+1,j) - QV1D(i)=QV3D(i,kts,j) - QC1D(i)=QC3D(i,kts,j) - P1D(i) =P3D(i,kts,j) - T1D(i) =T3D(i,kts,j) - if (spp_pbl==1) then - rstoch1D(i)=pattern_spp_pbl(i,kts,j) - else - rstoch1D(i)=0.0 - endif - ENDDO - - IF (itimestep==1 .AND. iter==1) THEN - DO i=its,ite - !Everything here is used before calculated - UST_OCN(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - MOL(i,j)=0. ! Tstar - QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j)) - QSFC_OCN(i)=QSFC(i,j) - QSFC_LND(i)=QSFC(i,j) - QSFC_ICE(i)=QSFC(i,j) - qstar(i,j)=0.0 - QFX(i,j)=0. - HFX(i,j)=0. - QFLX(i,j)=0. - HFLX(i,j)=0. - ENDDO - ELSE - IF (LSM == 3) THEN - DO i=its,ite - QSFC_LND(i)=QSFC_RUC(i) - ENDDO - ENDIF - ENDIF + DO i=its,ite + dz8w1d(I) = dz8w(i,kts) + dz2w1d(I) = dz8w(i,kts+1) + U1D(i) =U3D(i,kts) + V1D(i) =V3D(i,kts) + !2nd model level winds - for diags with high-res grids + U1D2(i) =U3D(i,kts+1) + V1D2(i) =V3D(i,kts+1) + QV1D(i)=QV3D(i,kts) + QC1D(i)=QC3D(i,kts) + P1D(i) =P3D(i,kts) + T1D(i) =T3D(i,kts) + if (spp_pbl==1) then + rstoch1D(i)=pattern_spp_pbl(i,kts) + else + rstoch1D(i)=0.0 + endif + ENDDO - CALL SFCLAY1D_mynn( & - J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & - U1D2,V1D2,dz2w1d, & - PSFCPA(ims,j),PBLH(ims,j),MAVAIL(ims,j), & - XLAND(ims,j),DX(ims,j), & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & - ISFFLX,isftcflx,iz0tlnd, & - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) - itimestep,iter, & - wet, dry, icy, & !intent(in) - tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) - tsurf_ocn, tsurf_lnd, tsurf_ice, & !intent(in) - qsfc_ocn, qsfc_lnd, qsfc_ice, & !intent(in) - snowh_ocn, snowh_lnd, snowh_ice, & !intent(in) - ZNT_ocn, ZNT_lnd, ZNT_ice, & !intent(inout) - UST_ocn, UST_lnd, UST_ice, & !intent(inout) - cm_ocn, cm_lnd, cm_ice, & !intent(inout) - ch_ocn, ch_lnd, ch_ice, & !intent(inout) - rb_ocn, rb_lnd, rb_ice, & !intent(inout) - stress_ocn, stress_lnd, stress_ice, & !intent(inout) - fm_ocn, fm_lnd, fm_ice, & !intent(inout) - fh_ocn, fh_lnd, fh_ice, & !intent(inout) - fm10_ocn, fm10_lnd, fm10_ice, & !intent(inout) - fh2_ocn, fh2_lnd, fh2_ice, & - HFLX_ocn, HFLX_lnd, HFLX_ice, & - QFLX_ocn, QFLX_lnd, QFLX_ice, & - ch(ims,j),CHS(ims,j),CHS2(ims,j),CQS2(ims,j), & - CPM(ims,j), & - ZNT(ims,j),USTM(ims,j),ZOL(ims,j), & - MOL(ims,j),RMOL(ims,j), & - PSIM(ims,j),PSIH(ims,j), & - HFLX(ims,j),HFX(ims,j),QFLX(ims,j),QFX(ims,j), & - LH(ims,j),FLHC(ims,j),FLQC(ims,j), & - QGH(ims,j),QSFC(ims,j), & - U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j),Q2(ims,j),& - GZ1OZ0(ims,j),WSPD(ims,j),wstar(ims,j), & - spp_pbl,rstoch1D, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) + IF (itimestep==1 .AND. iter==1) THEN + DO i=its,ite + !Everything here is used before calculated + UST_OCN(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + MOL(i)=0.0 + QSFC(i)=QV3D(i,kts)/(1.+QV3D(i,kts)) + QSFC_OCN(i)=QSFC(i) + QSFC_LND(i)=QSFC(i) + QSFC_ICE(i)=QSFC(i) + qstar(i)=0.0 + QFX(i)=0. + HFX(i)=0. + QFLX(i)=0. + HFLX(i)=0. + ENDDO + ELSE + IF (LSM == 3) THEN + DO i=its,ite + QSFC_LND(i)=QSFC_RUC(i) + ENDDO + ENDIF + ENDIF - ENDDO + CALL SFCLAY1D_mynn( & + J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & + U1D2,V1D2,dz2w1d, & + PSFCPA,PBLH,MAVAIL,XLAND,DX, & + CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & + EP1,EP2,KARMAN, & + ISFFLX,isftcflx,iz0tlnd,psi_opt, & + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) + itimestep,iter, & + wet, dry, icy, & !intent(in) + tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) + tsurf_ocn, tsurf_lnd, tsurf_ice, & !intent(in) + qsfc_ocn, qsfc_lnd, qsfc_ice, & !intent(in) + snowh_ocn, snowh_lnd, snowh_ice, & !intent(in) + ZNT_ocn, ZNT_lnd, ZNT_ice, & !intent(inout) + UST_ocn, UST_lnd, UST_ice, & !intent(inout) + cm_ocn, cm_lnd, cm_ice, & !intent(inout) + ch_ocn, ch_lnd, ch_ice, & !intent(inout) + rb_ocn, rb_lnd, rb_ice, & !intent(inout) + stress_ocn, stress_lnd, stress_ice, & !intent(inout) + fm_ocn, fm_lnd, fm_ice, & !intent(inout) + fh_ocn, fh_lnd, fh_ice, & !intent(inout) + fm10_ocn, fm10_lnd, fm10_ice, & !intent(inout) + fh2_ocn, fh2_lnd, fh2_ice, & + HFLX_ocn, HFLX_lnd, HFLX_ice, & + QFLX_ocn, QFLX_lnd, QFLX_ice, & + ch,CHS,CHS2,CQS2,CPM, & + ZNT,USTM,ZOL,MOL,RMOL, & + PSIM,PSIH, & + HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & + QGH,QSFC,U10,V10,TH2,T2,Q2, & + GZ1OZ0,WSPD,wstar, & + spp_pbl,rstoch1D, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte & + ) END SUBROUTINE SFCLAY_MYNN @@ -505,10 +498,10 @@ SUBROUTINE SFCLAY1D_mynn( & PSFCPA,PBLH,MAVAIL,XLAND,DX, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & - ISFFLX,isftcflx,iz0tlnd, & - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) + ISFFLX,isftcflx,iz0tlnd,psi_opt, & + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) itimestep,iter, & wet, dry, icy, & !intent(in) tskin_ocn, tskin_lnd, tskin_ice, & !intent(in) @@ -560,7 +553,7 @@ SUBROUTINE SFCLAY1D_mynn( & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, INTENT(IN) :: spp_pbl + INTEGER, INTENT(IN) :: spp_pbl, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -676,7 +669,7 @@ SUBROUTINE SFCLAY1D_mynn( & REAL :: PL,E1,TABS REAL :: WSPD_lnd, WSPD_ice, WSPD_ocn - REAL :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0 + REAL :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT REAL :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 REAL :: FLUXC,VSGD REAL :: restar,VISC,DQG,OLDUST,OLDTST @@ -891,8 +884,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_ocn(I)=MAX(rb_ocn(I),-2.0) rb_ocn(I)=MIN(rb_ocn(I), 2.0) ELSE - rb_ocn(I)=MAX(rb_ocn(I),-50.0) - rb_ocn(I)=MIN(rb_ocn(I), 50.0) + rb_ocn(I)=MAX(rb_ocn(I),-10.0) + rb_ocn(I)=MIN(rb_ocn(I), 10.0) ENDIF ENDIF ! end water point @@ -931,8 +924,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_lnd(I)=MAX(rb_lnd(I),-2.0) rb_lnd(I)=MIN(rb_lnd(I), 2.0) ELSE - rb_lnd(I)=MAX(rb_lnd(I),-50.0) - rb_lnd(I)=MIN(rb_lnd(I), 50.0) + rb_lnd(I)=MAX(rb_lnd(I),-10.0) + rb_lnd(I)=MIN(rb_lnd(I), 10.0) ENDIF ENDIF ! end land point @@ -965,8 +958,8 @@ SUBROUTINE SFCLAY1D_mynn( & rb_ice(I)=MAX(rb_ice(I),-2.0) rb_ice(I)=MIN(rb_ice(I), 2.0) ELSE - rb_ice(I)=MAX(rb_ice(I),-50.0) - rb_ice(I)=MIN(rb_ice(I), 50.0) + rb_ice(I)=MAX(rb_ice(I),-10.0) + rb_ice(I)=MIN(rb_ice(I), 10.0) ENDIF ENDIF ! end ice point @@ -1121,11 +1114,11 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF GZ1OZ0_ocn(I)= LOG((ZA(I)+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ1OZt_ocn(I)= LOG((ZA(I)+ZT_ocn(i))/ZT_ocn(i)) + GZ1OZt_ocn(I)= LOG((ZA(I)+ZNTstoch_ocn(i))/ZT_ocn(i)) GZ2OZ0_ocn(I)= LOG((2.0+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ2OZt_ocn(I)= LOG((2.0+ZT_ocn(i))/ZT_ocn(i)) + GZ2OZt_ocn(I)= LOG((2.0+ZNTstoch_ocn(i))/ZT_ocn(i)) GZ10OZ0_ocn(I)=LOG((10.+ZNTstoch_ocn(I))/ZNTstoch_ocn(I)) - GZ10OZt_ocn(I)=LOG((10.+ZT_ocn(i))/ZT_ocn(i)) + GZ10OZt_ocn(I)=LOG((10.+ZNTstoch_ocn(i))/ZT_ocn(i)) zratio_ocn(i)=ZNTstoch_ocn(I)/ZT_ocn(I) !need estimate for Li et al. ENDIF !end water point @@ -1178,11 +1171,11 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ1OZt_lnd(I)= LOG((ZA(I)+ZT_lnd(i))/ZT_lnd(i)) + GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) GZ2OZ0_lnd(I)= LOG((2.0+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ2OZt_lnd(I)= LOG((2.0+ZT_lnd(i))/ZT_lnd(i)) + GZ2OZt_lnd(I)= LOG((2.0+ZNTstoch_lnd(i))/ZT_lnd(i)) GZ10OZ0_lnd(I)=LOG((10.+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) - GZ10OZt_lnd(I)=LOG((10.+ZT_lnd(i))/ZT_lnd(i)) + GZ10OZt_lnd(I)=LOG((10.+ZNTstoch_lnd(i))/ZT_lnd(i)) zratio_lnd(i)=ZNTstoch_lnd(I)/ZT_lnd(I) !need estimate for Li et al. ENDIF !end land point @@ -1207,11 +1200,11 @@ SUBROUTINE SFCLAY1D_mynn( & CALL Andreas_2002(ZNTstoch_ice(i),visc,ust_ice(i),ZT_ice(i),ZQ_ice(i)) GZ1OZ0_ice(I)= LOG((ZA(I)+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ1OZt_ice(I)= LOG((ZA(I)+ZT_ice(i))/ZT_ice(i)) + GZ1OZt_ice(I)= LOG((ZA(I)+ZNTstoch_ice(i))/ZT_ice(i)) GZ2OZ0_ice(I)= LOG((2.0+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ2OZt_ice(I)= LOG((2.0+ZT_ice(i))/ZT_ice(i)) + GZ2OZt_ice(I)= LOG((2.0+ZNTstoch_ice(i))/ZT_ice(i)) GZ10OZ0_ice(I)=LOG((10.+ZNTstoch_ice(I))/ZNTstoch_ice(I)) - GZ10OZt_ice(I)=LOG((10.+ZT_ice(i))/ZT_ice(i)) + GZ10OZt_ice(I)=LOG((10.+ZNTstoch_ice(i))/ZT_ice(i)) zratio_ice(i)=ZNTstoch_ice(I)/ZT_ice(I) !need estimate for Li et al. ENDIF !end ice point @@ -1234,13 +1227,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_ocn(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),20.) IF (debug_code >= 1) THEN IF (ZNTstoch_ocn(i) < 1E-8 .OR. Zt_ocn(i) < 1E-10) THEN @@ -1252,11 +1242,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I)) + !zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),zt_ocn(I),GZ1OZ0_ocn(I),GZ1OZt_ocn(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_ocn(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ocn(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ocn(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ocn(I))/za(I) ! (10+z0)/L @@ -1269,11 +1263,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ocn(I),ZNTstoch_ocn(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) ! or use tables - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1298,13 +1292,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ocn(I),ZA(I)/ZNTstoch_ocn(I),zratio_ocn(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ocn(I)*UST_ocn(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_ocn(i) < 1E-8 .OR. Zt_ocn(i) < 1E-10) THEN @@ -1316,11 +1307,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),ZT_ocn(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ocn(I),ZA(I),ZNTstoch_ocn(I),zt_ocn(I),GZ1OZ0_ocn(I),GZ1OZt_ocn(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_ocn(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ocn(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ocn(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ocn(I))/za(I) ! (10+z0)/L @@ -1332,11 +1327,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ocn(I),ZNTstoch_ocn(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1365,13 +1360,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_lnd(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),50.) IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1383,11 +1375,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I)) + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_lnd(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_lnd(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_lnd(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_lnd(I))/za(I) ! (10+z0)/L @@ -1399,11 +1395,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_lnd(I),ZNTstoch_lnd(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1428,13 +1424,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1446,11 +1439,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_lnd(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_lnd(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_lnd(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_lnd(I))/za(I) ! (10+z0)/L @@ -1461,11 +1458,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_lnd(I),ZNTstoch_lnd(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1494,13 +1491,10 @@ SUBROUTINE SFCLAY1D_mynn( & IF (rb_ice(I) .GT. 0.0) THEN !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),50.) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0) + ZOL(I)=MIN(ZOL(I),50.) IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN @@ -1512,11 +1506,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I)) + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) ZOL(I)=MAX(ZOL(I),0.0) ZOL(I)=MIN(ZOL(I),50.) + zolzt = zol(I)*zt_ice(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ice(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ice(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ice(I))/za(I) ! (10+z0)/L @@ -1528,11 +1526,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ice(I),ZNTstoch_ice(I),ZA(I)) !CALL PSI_CB2005(PSIM(I),PSIH(I),zolza,zolz0) - psim(I)=psim_stable(zolza)-psim_stable(zolz0) - psih(I)=psih_stable(zolza)-psih_stable(zolz0) - psim10(I)=psim_stable(zol10)-psim_stable(zolz0) - psih10(I)=psih_stable(zol10)-psih_stable(zolz0) - psih2(I)=psih_stable(zol2)-psih_stable(zolz0) + psim(I)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(I)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(I)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(I)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(I)=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) ! 1.0 over Monin-Obukhov length RMOL(I)= ZOL(I)/ZA(I) @@ -1557,13 +1555,10 @@ SUBROUTINE SFCLAY1D_mynn( & !========================================================== !COMPUTE z/L first guess: - IF (itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-50.0) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0) + ZOL(I)=MIN(ZOL(I),0.0) IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN @@ -1575,11 +1570,15 @@ SUBROUTINE SFCLAY1D_mynn( & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF + !Use Pedros iterative function to find z/L - zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I)) - ZOL(I)=MAX(ZOL(I),-50.0) + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ZOL(I)=MAX(ZOL(I),-20.0) ZOL(I)=MIN(ZOL(I),0.0) + zolzt = zol(I)*zt_ice(I)/ZA(I) ! zt/L zolz0 = zol(I)*ZNTstoch_ice(I)/ZA(I) ! z0/L zolza = zol(I)*(za(I)+ZNTstoch_ice(I))/za(I) ! (z+z0/L zol10 = zol(I)*(10.+ZNTstoch_ice(I))/za(I) ! (10+z0)/L @@ -1590,11 +1589,11 @@ SUBROUTINE SFCLAY1D_mynn( & !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) !CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),ZT_ice(I),ZNTstoch_ice(I),ZA(I)) ! use tables - psim(I)=psim_unstable(zolza)-psim_unstable(zolz0) - psih(I)=psih_unstable(zolza)-psih_unstable(zolz0) - psim10(I)=psim_unstable(zol10)-psim_unstable(zolz0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zolz0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zolz0) + psim(I)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(I)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(I)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(I)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(I)=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES @@ -1644,7 +1643,7 @@ SUBROUTINE SFCLAY1D_mynn( & !NON-AVERAGED: !UST_lnd(I)=KARMAN*WSPD(I)/PSIX_lnd(I) !From Tilden Meyers: - !IF (rb_lnd(I) .GE 0.0) THEN + !IF (rb_lnd(I) .GE. 0.0) THEN ! ust_lnd(i)=WSPD_lnd*0.1/(1.0 + 10.0*rb_lnd(I)) !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird @@ -2546,6 +2545,10 @@ SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) END SUBROUTINE GFS_z0_lnd !-------------------------------------------------------------------- ! Taken from the GFS (sfc_diff.f) for comparison +! This formulation comes from Zheng et al. (2012, JGR), which is a +! modified form of the Zilitinkevich thermal roughness length but it adds +! the dependence on vegetation fraction. +! SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) REAL, INTENT(OUT) :: ztmax @@ -3227,18 +3230,21 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) END SUBROUTINE Li_etal_2010 !------------------------------------------------------------------- - REAL function zolri(ri,za,z0,zt,zol1) + REAL function zolri(ri,za,z0,zt,zol1,psi_opt) ! This iterative algorithm was taken from the revised surface layer ! scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and ! summarized in Jimenez et al. (2012, MWR). This function was adapted - ! to input the thermal roughness length, zt, (as well as z0) because - ! zt is necessary input for the Dyer-Hicks functions used in MYNN. + ! to input the thermal roughness length, zt, (as well as z0) and use initial + ! estimate of z/L. IMPLICIT NONE REAL, INTENT(IN) :: ri,za,z0,zt,zol1 + INTEGER, INTENT(IN) :: psi_opt REAL :: x1,x2,fx1,fx2 INTEGER :: n + INTEGER, PARAMETER :: nmax = 20 + !REAL, DIMENSION(nmax):: zLhux if (ri.lt.0.)then x1=zol1 - 0.02 !-5. @@ -3248,40 +3254,38 @@ REAL function zolri(ri,za,z0,zt,zol1) x2=zol1 + 0.02 !5. endif - n=0 - fx1=zolri2(x1,ri,za,z0,zt) - fx2=zolri2(x2,ri,za,z0,zt) - Do While (abs(x1 - x2) > 0.01 .and. n < 5) + n=1 + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + + Do While (abs(x1 - x2) > 0.01 .and. n < nmax) if(abs(fx2).lt.abs(fx1))then x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,za,z0,zt) + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) zolri=x1 else x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,za,z0,zt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) zolri=x2 endif n=n+1 !print*," n=",n," x1=",x1," x2=",x2 + !zLhux(n)=zolri enddo - if (n==5 .and. abs(x1 - x2) >= 0.01) then - !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri - !Tests results: fails convergence ~ 0.07 % of the time - !set approximate values: - if (ri.lt.0.)then - zolri=ri*5. - else - zolri=ri*8. - endif - !else - ! print*,"iter OK, n=",n," Ri=",ri," z/L=",zolri + if (n==nmax .and. abs(x1 - x2) >= 0.01) then + !if convergence fails, use approximate values: + CALL Li_etal_2010(zolri, ri, za/z0, z0/zt) + !zLhux(n)=zolri + !print*,"iter FAIL, n=",n," Ri=",ri," z0=",z0 + else + !print*,"SUCCESS,n=",n," Ri=",ri," z0=",z0 endif return end function !------------------------------------------------------------------- - REAL function zolri2(zol2,ri2,za,z0,zt) + REAL function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! INPUT: ================================= ! zol2 - estimated z/L @@ -3290,59 +3294,150 @@ REAL function zolri2(zol2,ri2,za,z0,zt) ! z0 - aerodynamic roughness length ! zt - thermal roughness length ! OUTPUT: ================================ - ! zolri2 - updated estimate of z/L + ! zolri2 - delta Ri IMPLICIT NONE + INTEGER, INTENT(IN) :: psi_opt REAL, INTENT(IN) :: ri2,za,z0,zt REAL, INTENT(INOUT) :: zol2 - REAL :: zol20,zol3,psim1,psih1,psix2,psit2 + REAL :: zol20,zol3,psim1,psih1,psix2,psit2,zolt if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 zol20=zol2*z0/za ! z0/L zol3=zol2+zol20 ! (z+z0)/L + zolt=zol2*zt/za ! zt/L if (ri2.lt.0) then - !CALL PSI_DyerHicks(psim1,psih1,zol3,zt,z0,za) - psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - !psix2=log((za+z0)/z0)-psim1 - !psit2=log((za+zt)/zt)-psih1 + !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=MAX(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=MAX(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) else - !CALL PSI_DyerHicks(psim1,psih1,zol2,zt,z0,za) - !CALL PSI_CB2005(psim1,psih1,zol3,zol20) - psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - !psix2=log((za+z0)/z0)-psim1 - !psit2=log((za+zt)/zt)-psih1 + !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=MAX(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=MAX(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) endif zolri2=zol2*psit2/psix2**2 - ri2 + !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 return end function !==================================================================== - SUBROUTINE psi_init - INTEGER :: N - REAL :: zolf + REAL function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) - DO N=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) + ! This iterative algorithm to compute z/L from bulk-Ri - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - ENDDO + IMPLICIT NONE + REAL, INTENT(IN) :: ri,za,z0,zt,logz0,logzt + INTEGER, INTENT(IN) :: psi_opt + REAL, INTENT(INOUT) :: zol1 + REAL :: zol20,zol3,zolt,zolold + INTEGER :: n + INTEGER, PARAMETER :: nmax = 20 + REAL, DIMENSION(nmax):: zLhux + REAL :: psit2,psix2 + + !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri + if (zol1*ri .lt. 0.) THEN + !print*,"begin: WRONG QUADRANTS: z/L=",zol1," ri=",ri + zol1=0. + endif + + if (ri .lt. 0.) then + zolold=-99999. + zolrib=-66666. + else + zolold=99999. + zolrib=66666. + endif + n=1 + + DO While (abs(zolold - zolrib) > 0.01 .and. n < nmax) + + if(n==1)then + zolold=zol1 + else + zolold=zolrib + endif + zol20=zolold*z0/za ! z0/L + zol3=zolold+zol20 ! (z+z0)/L + zolt=zolold*zt/za ! zt/L + !print*,"z0/L=",zol20," (z+z0)/L=",zol3," zt/L=",zolt + if (ri.lt.0) then + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=MAX(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) + else + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=MAX(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) + endif + !print*,"n=",n," psit2=",psit2," psix2=",psix2 + zolrib=ri*psix2**2/psit2 + zLhux(n)=zolrib + n=n+1 + enddo + + if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then + !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri + !if convergence fails, use approximate values: + CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) + zLhux(n)=zolrib + !print*,"FAILED, n=",n," Ri=",ri," z0=",z0 + !print*,"z/L=",zLhux(1:nmax) + else + !if(zolrib*ri .lt. 0.) THEN + ! !print*,"end: WRONG QUADRANTS: z/L=",zolrib," ri=",ri + ! !CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) + !endif + !print*,"SUCCESS,n=",n," Ri=",ri," z0=",z0 + endif + + return + end function +!==================================================================== + + SUBROUTINE psi_init(psi_opt) + + INTEGER :: N,psi_opt + REAL :: zolf + + if (psi_opt == 0) then + DO N=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + ENDDO + else + DO N=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full_gfs(zolf) + psih_stab(n)=psih_stable_full_gfs(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full_gfs(zolf) + psih_unstab(n)=psih_unstable_full_gfs(zolf) + ENDDO + endif END SUBROUTINE psi_init ! ================================================================== -! ... integrated similarity functions ... -! +! ... integrated similarity functions from MYNN... +! REAL function psim_stable_full(zolf) REAL :: zolf @@ -3392,11 +3487,73 @@ REAL function psih_unstable_full(zolf) return end function + +! ================================================================== +! ... integrated similarity functions from GFS... +! + REAL function psim_stable_full_gfs(zolf) + REAL :: zolf + REAL, PARAMETER :: alpha4 = 20. + REAL :: aa + + aa = sqrt(1. + alpha4 * zolf) + psim_stable_full_gfs = -1.*aa + log(aa + 1.) + + return + end function + + REAL function psih_stable_full_gfs(zolf) + REAL :: zolf + REAL, PARAMETER :: alpha4 = 20. + REAL :: bb + + bb = sqrt(1. + alpha4 * zolf) + psih_stable_full_gfs = -1.*bb + log(bb + 1.) + + return + end function + + REAL function psim_unstable_full_gfs(zolf) + REAL :: zolf + REAL :: hl1,tem1 + REAL, PARAMETER :: a0=-3.975, a1=12.32, & + b1=-7.755, b2=6.041 + + if (zolf .ge. -0.5) then + hl1 = zolf + psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 + end if + + return + end function + + REAL function psih_unstable_full_gfs(zolf) + REAL :: zolf + REAL :: hl1,tem1 + REAL, PARAMETER :: a0p=-7.941, a1p=24.75, & + b1p=-8.705, b2p=7.899 + + if (zolf .ge. -0.5) then + hl1 = zolf + psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 + end if + + return + end function + !================================================================= -! look-up table functions +! look-up table functions - or, if beyond -10 < z/L < 10, recalculate !================================================================= - REAL function psim_stable(zolf) - integer :: nzol + REAL function psim_stable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(zolf*100.) @@ -3404,14 +3561,18 @@ REAL function psim_stable(zolf) if(nzol+1 .le. 1000)then psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) else - psim_stable = psim_stable_full(zolf) + if (psi_opt == 0) then + psim_stable = psim_stable_full(zolf) + else + psim_stable = psim_stable_full_gfs(zolf) + endif endif return end function - REAL function psih_stable(zolf) - integer :: nzol + REAL function psih_stable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(zolf*100.) @@ -3419,14 +3580,18 @@ REAL function psih_stable(zolf) if(nzol+1 .le. 1000)then psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) else - psih_stable = psih_stable_full(zolf) + if (psi_opt == 0) then + psih_stable = psih_stable_full(zolf) + else + psih_stable = psih_stable_full_gfs(zolf) + endif endif return end function - REAL function psim_unstable(zolf) - integer :: nzol + REAL function psim_unstable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(-zolf*100.) @@ -3434,14 +3599,18 @@ REAL function psim_unstable(zolf) if(nzol+1 .le. 1000)then psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) else - psim_unstable = psim_unstable_full(zolf) + if (psi_opt == 0) then + psim_unstable = psim_unstable_full(zolf) + else + psim_unstable = psim_unstable_full_gfs(zolf) + endif endif return end function - REAL function psih_unstable(zolf) - integer :: nzol + REAL function psih_unstable(zolf,psi_opt) + integer :: nzol,psi_opt real :: rzol,zolf nzol = int(-zolf*100.) @@ -3449,7 +3618,11 @@ REAL function psih_unstable(zolf) if(nzol+1 .le. 1000)then psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) else - psih_unstable = psih_unstable_full(zolf) + if (psi_opt == 0) then + psih_unstable = psih_unstable_full(zolf) + else + psih_unstable = psih_unstable_full_gfs(zolf) + endif endif return diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 7345f2667..024f97772 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7022,8 +7022,8 @@ END SUBROUTINE SOILVEGIN !> This subroutine computes liquid and forezen soil moisture from the !! total soil moisture, and also computes soil moisture availability in !! the top soil layer. - SUBROUTINE RUCLSMINIT( debug_print, landmask, & - nzs, isltyp, ivgtyp, xice, mavail, & + SUBROUTINE RUCLSMINIT( debug_print, slmsk, & + nzs, isltyp, ivgtyp, mavail, & sh2o, smfr3d, tslb, smois, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -7035,35 +7035,32 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - + REAL, DIMENSION( ims:ime), INTENT(IN ) :: slmsk INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(IN) :: TSLB, & - SMOIS - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN) :: LANDMASK + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(IN) :: TSLB, & + SMOIS - INTEGER, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ISLTYP,IVGTYP + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ISLTYP,IVGTYP - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(INOUT) :: SMFR3D, & - SH2O + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(OUT) :: SMFR3D, & + SH2O - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: XICE,MAVAIL + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: MAVAIL - REAL, DIMENSION ( 1:nzs ) :: SOILIQW + !-- local + REAL, DIMENSION ( 1:nzs ) :: SOILIQW -! - INTEGER :: I,J,L,itf,jtf - REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + INTEGER :: I,J,L,itf,jtf + REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7077,9 +7074,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & errflag = 0 DO j = jts,jtf DO i = its,itf - ! land-only version - IF ( LANDMASK( i,j ) .NE. 1 ) CYCLE - ! + IF ( ISLTYP( i,j ) .LT. 0 ) THEN errflag = 1 print *, & @@ -7096,65 +7091,60 @@ SUBROUTINE RUCLSMINIT( debug_print, landmask, & DO J=jts,jtf DO I=its,itf - ! land-only version - IF ( LANDMASK( i,j ) .NE. 1 ) CYCLE - -!--- Computation of volumetric content of ice in soil -!--- and initialize MAVAIL - if(ISLTYP(I,J) > 0) then - DQM = MAXSMC (ISLTYP(I,J)) - & - DRYSMC (ISLTYP(I,J)) - REF = REFSMC (ISLTYP(I,J)) - PSIS = - SATPSI (ISLTYP(I,J)) - QMIN = DRYSMC (ISLTYP(I,J)) - BCLH = BB (ISLTYP(I,J)) - endif - + ! in Zobler classification isltyp=0 for water. Statsgo classification + ! has isltyp=14 for water + if (isltyp(i,j) == 0) isltyp(i,j)=14 + + if(slmsk(i) == 1. ) then + !-- land + !-- Computate volumetric content of ice in soil + !-- and initialize MAVAIL + DQM = MAXSMC (ISLTYP(I,J)) - & + DRYSMC (ISLTYP(I,J)) + REF = REFSMC (ISLTYP(I,J)) + PSIS = - SATPSI (ISLTYP(I,J)) + QMIN = DRYSMC (ISLTYP(I,J)) + BCLH = BB (ISLTYP(I,J)) + + mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) -! in Zobler classification isltyp=0 for water. Statsgo classification -! has isltyp=14 for water - if (isltyp(i,j) == 0) isltyp(i,j)=14 + DO L=1,NZS + !-- for land points initialize soil ice + tln=log(TSLB(i,l,j)/273.15) + + if(tln.lt.0.) then + soiliqw(l)=(dqm+qmin)*(XLMELT* & + (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & + **(-1./bclh) + !**(-1./bclh)-qmin + soiliqw(l)=max(0.,soiliqw(l)) + soiliqw(l)=min(soiliqw(l),smois(i,l,j)) + sh2o(i,l,j)=soiliqw(l) + smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW + + else + smfr3d(i,l,j)=0. + sh2o(i,l,j)=smois(i,l,j) + endif + ENDDO - IF(xice(i,j).gt.0.) THEN -!-- for ice + elseif( slmsk(i) == 2.) then + !-- ice + mavail(i,j) = 1. DO L=1,NZS smfr3d(i,l,j)=1. sh2o(i,l,j)=0. - mavail(i,j) = 1. - ENDDO - ELSE - if(isltyp(i,j).ne.14 ) then -!-- land - mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) - DO L=1,NZS -!-- for land points initialize soil ice - tln=log(TSLB(i,l,j)/273.15) - - if(tln.lt.0.) then - soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & - **(-1./bclh) -! **(-1./bclh)-qmin - soiliqw(l)=max(0.,soiliqw(l)) - soiliqw(l)=min(soiliqw(l),smois(i,l,j)) - sh2o(i,l,j)=soiliqw(l) - smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW - - else - smfr3d(i,l,j)=0. - sh2o(i,l,j)=smois(i,l,j) - endif ENDDO else -!-- for water ISLTYP=14 + !-- water ISLTYP=14 + mavail(i,j) = 1. DO L=1,NZS smfr3d(i,l,j)=0. sh2o(i,l,j)=1. - mavail(i,j) = 1. ENDDO - endif - ENDIF + + endif ! land ENDDO ENDDO diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 3158865a1..f6be851b1 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -16,6 +16,8 @@ module lsm_ruc public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize + real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, epsln = 1.0d-10 + contains !> This subroutine calls set_soilveg_ruc() to specify vegetation and soil parameters for @@ -23,19 +25,62 @@ module lsm_ruc !! \section arg_table_lsm_ruc_init Argument Table !! \htmlinclude lsm_ruc_init.html !! - subroutine lsm_ruc_init (me, isot, ivegsrc, nlunit, & - & errmsg, errflg) + subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & + flag_restart, flag_init, & + im, lsoil_ruc, lsoil, kice, nlev, & ! in + lsm_ruc, lsm, slmsk, stype, vtype, & ! in + tsfc_lnd, tsfc_wat, & ! in + tg3, smc, slc, stc, & ! in + zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out + tsice, errmsg, errflg) implicit none +! --- in + integer, intent(in) :: me, master, isot, ivegsrc, nlunit + logical, intent(in) :: flag_restart + logical, intent(in) :: flag_init + integer, intent(in) :: im + integer, intent(in) :: lsoil_ruc + integer, intent(in) :: lsoil + integer, intent(in) :: kice + integer, intent(in) :: nlev + integer, intent(in) :: lsm_ruc, lsm + + + real (kind=kind_phys), dimension(im), intent(in) :: slmsk + real (kind=kind_phys), dimension(im), intent(in) :: stype + real (kind=kind_phys), dimension(im), intent(in) :: vtype + real (kind=kind_phys), dimension(im), intent(in) :: tsfc_lnd + real (kind=kind_phys), dimension(im), intent(in) :: tsfc_wat + real (kind=kind_phys), dimension(im), intent(in) :: tg3 + + real (kind=kind_phys), dimension(im,lsoil), intent(in) :: smc,slc,stc + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: wetness + +! --- out + real (kind=kind_phys), dimension(:), intent(out) :: zs + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o, smfrkeep + real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb, smois + real (kind=kind_phys), dimension(im,kice), intent(out) :: tsice - integer, intent(in) :: me, isot, ivegsrc, nlunit character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg +! --- local + real (kind=kind_phys), dimension(lsoil_ruc) :: dzs + integer :: ipr, i, k + logical :: debug_print + integer, dimension(im) :: soiltyp, vegtype + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + ipr = 10 + debug_print = .false. + if (ivegsrc /= 1) then errmsg = 'The RUC LSM expects that the ivegsrc physics namelist parameter is 1. Exiting...' errflg = 1 @@ -47,9 +92,81 @@ subroutine lsm_ruc_init (me, isot, ivegsrc, nlunit, & return end if +!> - Call rucinit() to initialize soil/ice/water variables + + if ( debug_print) then + write (0,*) 'RUC LSM initialization' + write (0,*) 'lsoil_ruc, lsoil',lsoil_ruc, lsoil + write (0,*) 'me, isot, ivegsrc, nlunit ',me, isot, ivegsrc, nlunit + write (0,*) 'noah soil temp',stc(ipr,:) + write (0,*) 'noah mois(ipr)',ipr,smc(ipr,:) + write (0,*) 'stype=',stype(ipr) + write (0,*) 'vtype=',vtype(ipr) + write (0,*) 'tsfc_lnd=',tsfc_lnd(ipr) + write (0,*) 'tsfc_wat=',tsfc_wat(ipr) + write (0,*) 'tg3=',tg3(ipr) + write (0,*) 'slmsk=',slmsk(ipr) + write (0,*) 'flag_init =',flag_init + write (0,*) 'flag_restart =',flag_restart + endif + !--- initialize soil vegetation call set_soilveg_ruc(me, isot, ivegsrc, nlunit) + soiltyp(:) = 0 + vegtype(:) = 0 + + do i = 1, im ! i - horizontal loop + if (slmsk(i) == 2.) then + !-- ice + if (isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (ivegsrc == 1) then + vegtype(i) = 15 + elseif(ivegsrc == 2) then + vegtype(i) = 13 + endif + else + !-- land or water + soiltyp(i) = int( stype(i)+0.5 ) + vegtype(i) = int( vtype(i)+0.5 ) + if (soiltyp(i) < 1) soiltyp(i) = 14 + if (vegtype(i) < 1) vegtype(i) = 17 + endif + enddo + + call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) + + !if( .not. flag_restart) then + call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) + + do i = 1, im ! i - horizontal loop + do k = 1, min(kice,lsoil_ruc) + ! - at initial time set sea ice T (tsice) + ! equal to TSLB, initialized from the Noah STC variable + tsice (i,k) = tslb(i,k) + enddo + enddo ! i + + !endif ! flag_restart + !-- end of initialization + + if ( debug_print) then + write (0,*) 'ruc soil tslb',tslb(ipr,:) + write (0,*) 'ruc soil tsice',tsice(ipr,:) + write (0,*) 'ruc soil smois',smois(ipr,:) + write (0,*) 'ruc wetness',wetness(ipr) + endif + end subroutine lsm_ruc_init !! \section arg_table_lsm_ruc_finalize Argument Table @@ -201,8 +318,7 @@ subroutine lsm_ruc_run & ! inputs ! --- in/out: integer, dimension(im), intent(inout) :: soiltyp, vegtype - real (kind=kind_phys), dimension(lsoil_ruc) :: dzs - real (kind=kind_phys), dimension(lsoil_ruc), intent(inout ) :: zs + real (kind=kind_phys), dimension(lsoil_ruc), intent(in) :: zs real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & & snwdph, tskin, tskin_wat, & & srflag, canopy, trans, tsurf, zorl, tsnow, & @@ -313,26 +429,6 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'flag_init =',flag_init write (0,*)'flag_restart =',flag_restart endif - -!> - Call rucinit() at the first time step and the first interation -!! for RUC initialization,then overwrite Noah soil fields -!! with initialized RUC soil fields for output. - if(flag_init .and. iter==1) then - if (debug_print) write (0,'(a,i0,a,l)') 'RUC LSM initialization, kdt = ', kdt, ', flag_restart = ', flag_restart - - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - isot, soiltyp, vegtype, fice, & ! in - land, tskin, tskin_wat, tg3, & ! in - smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout - lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out - me, master, errmsg, errflg) - - xlai = 0. - - endif ! flag_init=.true.,iter=1 -!-- end of initialization ims = 1 its = 1 @@ -617,7 +713,11 @@ subroutine lsm_ruc_run & ! inputs albbck(i,j) = max(0.01, 0.5 * (alvwf(i) + alnwf(i))) alb(i,j) = sfalb(i) - if(rdlai2d) xlai(i,j) = laixy(i) + if(rdlai2d) then + xlai(i,j) = laixy(i) + else + xlai(i,j) = 0. + endif tbot(i,j) = tg3(i) @@ -704,7 +804,7 @@ subroutine lsm_ruc_run & ! inputs znt(i,j) = zorl(i)/100. if(debug_print) then - if(me==0 .and. i==ipr) then + if(i==ipr) then write (0,*)'before RUC smsoil = ',smsoil(i,:,j), i,j write (0,*)'stsoil = ',stsoil(i,:,j), i,j write (0,*)'soilt = ',soilt(i,j), i,j @@ -780,21 +880,8 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'stsoil(i,:,j)=',i,j,stsoil(i,:,j) write (0,*)'smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) write (0,*)'keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'hfx(i,j) =',i,j,hfx(i,j) - write (0,*)'qfx(i,j) =',i,j,qfx(i,j) - write (0,*)'lh(i,j) =',i,j,lh(i,j) - write (0,*)'infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'runoff2(i,j) =',i,j,runoff2(i,j) write (0,*)'acrunoff(i,j) =',i,j,acrunoff(i,j) - write (0,*)'sfcexc(i,j) =',i,j,sfcexc(i,j) - write (0,*)'acceta(i,j) =',i,j,acceta(i,j) - write (0,*)'ssoil(i,j) =',i,j,ssoil(i,j) - write (0,*)'snfallac(i,j) =',i,j,snfallac(i,j) write (0,*)'acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'snomlt(i,j) =',i,j,snomlt(i,j) write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) write (0,*)'rdlai2d =',rdlai2d @@ -836,7 +923,9 @@ subroutine lsm_ruc_run & ! inputs & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) - if(debug_print) then + if(debug_print) then + if(i==ipr) then + write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j write (0,*)'after sneqv(i,j) =',i,j,sneqv(i,j) write (0,*)'after snowh(i,j) =',i,j,snowh(i,j) write (0,*)'after sncovr(i,j) =',i,j,sncovr(i,j) @@ -871,6 +960,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) write (0,*)'after snomlt(i,j) =',i,j,snomlt(i,j) endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -882,16 +972,6 @@ subroutine lsm_ruc_run & ! inputs !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom !!\n \a snoh - phase-change heat flux from snowmelt (w m-2) ! - if(debug_print) then - !if(me==0.and.i==ipr) then - write (0,*)'after RUC smsoil = ',smsoil(i,:,j), i, j - write (0,*)'stsoil = ',stsoil(i,:,j), i,j - write (0,*)'soilt = ',soilt(i,j), i,j - write (0,*)'wet = ',wet(i,j), i,j - write (0,*)'soilt1 = ',soilt1(i,j), i,j - write (0,*)'rhosnfr = ',rhosnfr(i,j), i,j - !endif - endif ! Interstitial evap(i) = qfx(i,j) / rho(i) ! kinematic @@ -1014,30 +1094,14 @@ subroutine lsm_ruc_run & ! inputs deallocate(landusef) ! !! Update standard (Noah LSM) soil variables for physics - !! that require these variables (e.g. sfc_sice), independent - !! of whether it is a land point or not - !do i = 1, im - ! if (land(i)) then - ! do k = 1, lsoil - ! smc(i,k) = smois(i,k) - ! slc(i,k) = sh2o(i,k) - ! stc(i,k) = tslb(i,k) - ! enddo - ! endif - !enddo - ! - !write(0,*) "DH DEBUG: i, k, land(i), smc(i,k), slc(i,k), stc(i,k):" - !do i = 1, im - ! do k = 1, lsoil - ! write(0,'(2i5,1x,l,1x,3e20.10)'), i, k, land(i), smc(i,k), slc(i,k), stc(i,k) - ! smc(i,k) = smois(i,k) - ! slc(i,k) = sh2o(i,k) - ! stc(i,k) = tslb(i,k) - ! enddo - !enddo - - !call sleep(20) - !stop + !! that require these variables and for debugging purposes + do i = 1, im + do k = 1, lsoil + smc(i,k) = smois(i,k) + slc(i,k) = sh2o(i,k) + stc(i,k) = tslb(i,k) + enddo + enddo return !................................... @@ -1046,44 +1110,39 @@ end subroutine lsm_ruc_run !>\ingroup lsm_ruc_group !! This subroutine contains RUC LSM initialization. - subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in - isot, soiltyp, vegtype, fice, & ! in - land, tsurf, tsurf_wat, & ! in - tg3, smc, slc, stc, & ! in - smcref2, smcwlt2, & ! inout - lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, & ! out - wetness, me, master, errmsg, errflg) + subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tskin_lnd, tskin_wat, tg3, & ! !in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) implicit none - logical, intent(in ) :: restart - integer, intent(in ) :: lsm - integer, intent(in ) :: lsm_ruc - integer, intent(in ) :: isot - integer, intent(in ) :: im, nlev - integer, intent(in ) :: lsoil_ruc - integer, intent(in ) :: lsoil - logical, dimension(im), intent(in ) :: land - real (kind=kind_phys), dimension(im), intent(in ) :: tsurf, tsurf_wat - real (kind=kind_phys), dimension(im), intent(inout) :: smcref2 - real (kind=kind_phys), dimension(im), intent(inout) :: smcwlt2 - real (kind=kind_phys), dimension(im), intent(in ) :: tg3 - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah + logical, intent(in ) :: restart + integer, intent(in ) :: lsm + integer, intent(in ) :: lsm_ruc + integer, intent(in ) :: im, nlev + integer, intent(in ) :: lsoil_ruc + integer, intent(in ) :: lsoil + real (kind=kind_phys), dimension(im), intent(in ) :: slmsk + real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat + real (kind=kind_phys), dimension(im), intent(in ) :: tg3 + real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs + real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah + real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah integer, dimension(im), intent(inout) :: soiltyp integer, dimension(im), intent(inout) :: vegtype real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im), intent(inout) :: fice real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc - real (kind=kind_phys), dimension(1:lsoil_ruc), intent (out) :: zs - integer, intent(in ) :: me integer, intent(in ) :: master character(len=*), intent(out) :: errmsg @@ -1095,12 +1154,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in logical :: swi_init ! for initialization in terms of SWI (soil wetness index) integer :: flag_soil_layers, flag_soil_levels, flag_sst - real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind=kind_phys), dimension(im) :: smcref2 + real (kind=kind_phys), dimension(im) :: smcwlt2 integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp real (kind=kind_phys), dimension( 1:im , 1:1 ) :: mavail - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: xice real (kind=kind_phys), dimension( 1:im , 1:1 ) :: sst real (kind=kind_phys), dimension( 1:im , 1:1 ) :: landmask real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tsk @@ -1122,7 +1182,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in its,ite, jts,jte, kts,kte, & i, j, k, l, num_soil_layers, ipr - real(kind=kind_phys), dimension(1:lsoil_ruc) :: zs2, dzs integer, dimension(1:lsoil) :: st_levels_input ! 4 - for Noah lsm integer, dimension(1:lsoil) :: sm_levels_input ! 4 - for Noah lsm @@ -1142,6 +1201,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in else if (debug_print) then write (0,*) 'Start of RUC LSM initialization' write (0,*)'lsoil, lsoil_ruc =',lsoil, lsoil_ruc + write (0,*)'restart = ',restart endif ipr = 10 @@ -1166,9 +1226,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in kme = nlev kte = nlev - ! Initialize the RUC soil levels, needed for cold starts and warm starts - CALL init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - !! Check if RUC soil data (tslb, ...) is provided or not !if (minval(tslb)==maxval(tslb)) then ! For restart runs, can assume that RUC soul data is provided @@ -1212,6 +1269,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in if(debug_print) then write (0,*)'smc(ipr,:) ==', ipr, smc(ipr,:) write (0,*)'stc(ipr,:) ==', ipr, stc(ipr,:) + write (0,*)'tskin_lnd(:)=',tskin_lnd(:) + write (0,*)'tskin_wat(:)=',tskin_wat(:) write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) write (0,*)'its,ite,jts,jte ',its,ite,jts,jte @@ -1221,18 +1280,19 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte ! do i=its,ite ! i = horizontal loop - ! land only version - if (land(i)) then - tsk(i,j) = tsurf(i) - sst(i,j) = tsurf_wat(i) - tbot(i,j)= tg3(i) - ivgtyp(i,j)=vegtype(i) - isltyp(i,j)=soiltyp(i) - landmask(i,j)=1. - xice(i,j)=0. - else + sst(i,j) = tskin_wat(i) + tbot(i,j) = tg3(i) + ivgtyp(i,j) = vegtype(i) + isltyp(i,j) = soiltyp(i) + if (slmsk(i) == 0.) then + !-- water + tsk(i,j) = tskin_wat(i) landmask(i,j)=0. - endif ! land(i) + else + !-- land or ice + tsk(i,j) = tskin_lnd(i) + landmask(i,j)=1. + endif ! land(i) enddo enddo @@ -1242,19 +1302,22 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte ! do i=its,ite ! i = horizontal loop - if (land(i)) then - st_input(i,1,j)=tsk(i,j) sm_input(i,1,j)=0. !--- initialize smcwlt2 and smcref2 with Noah values - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + if(slmsk(i) == 1.) then + smcref2 (i) = REFSMCnoah(soiltyp(i)) + smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + else + smcref2 (i) = 1. + smcwlt2 (i) = 0. + endif do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(swi_init) then + if(slmsk(i) == 1. .and. swi_init) then sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else @@ -1266,8 +1329,6 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sm_input(i,k,j)=0. enddo - endif ! land(i) - enddo ! i - horizontal loop enddo ! jme @@ -1291,26 +1352,33 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (land(i)) then - do k=1,lsoil_ruc + if (slmsk(i) == 1.) then + !-- land + do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture - if(swi_init) then - soilm(i,k,j)= dumsm(i,k,j) * & + if(swi_init) then + soilm(i,k,j) = dumsm(i,k,j) * & (refsmc(isltyp(i,j))-drysmc(isltyp(i,j))) & + drysmc(isltyp(i,j)) - else - soilm(i,k,j)= dumsm(i,k,j) - endif + else + soilm(i,k,j) = dumsm(i,k,j) + endif soiltemp(i,k,j) = dumt(i,k,j) - enddo - endif ! land(i) + enddo ! k + else + !-- ice or water + do k=1,lsoil_ruc + soilm(i,k,j) = 1. + soiltemp(i,k,j) = dumt(i,k,j) + enddo ! k + endif ! land enddo enddo if(debug_print) then write (0,*)'tsk(i,j),tbot(i,j),sst(i,j),landmask(i,j)' & ,ipr,1,tsk(ipr,1),tbot(ipr,1),sst(ipr,1),landmask(ipr,1) - write (0,*)'tsurf(ipr)=',ipr,tsurf(ipr) + write (0,*)'tskin_lnd(ipr)=',ipr,tskin_lnd(ipr) write (0,*)'stc(ipr)=',ipr,stc(ipr,:) write (0,*)'smc(ipr)=',ipr,smc(ipr,:) write (0,*)'soilt(1,:,ipr)',ipr,soiltemp(ipr,:,1) @@ -1325,7 +1393,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (land(i)) then + if (slmsk(i) == 1.) then ! initialize factor do k=1,lsoil_ruc @@ -1401,15 +1469,15 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in ! Initialize liquid and frozen soil moisture from total soil moisture ! and soil temperature, and also soil moisture availability in the top ! layer - call ruclsminit( debug_print, landmask, & - lsoil_ruc, isltyp, ivgtyp, xice, mavail, & + + call ruclsminit( debug_print, slmsk, & + lsoil_ruc, isltyp, ivgtyp, mavail, & soilh2o, smfr, soiltemp, soilm, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) do j=jts,jte do i=its,ite - if (land(i)) then wetness(i) = mavail(i,j) do k = 1, lsoil_ruc smois(i,k) = soilm(i,k,j) @@ -1417,25 +1485,25 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sh2o(i,k) = soilh2o(i,k,j) smfrkeep(i,k) = smfr(i,k,j) enddo - endif ! land(i) enddo enddo - ! For non-land points, set RUC LSM fields to input (Noah or RUC) fields - do i=1,im - if (.not.land(i)) then - do k=1,min(lsoil,lsoil_ruc) - smois(i,k) = smc(i,k) - tslb(i,k) = stc(i,k) - sh2o(i,k) = slc(i,k) - enddo - endif - enddo + !do i=1,im + ! wetness (i) = 1. + ! do k=1,min(lsoil,lsoil_ruc) + ! smois(i,k) = smc(i,k) + ! tslb(i,k) = stc(i,k) + ! sh2o(i,k) = slc(i,k) + ! enddo + !enddo if(debug_print) then + do i=1,im write (0,*)'End of RUC LSM initialization' - write (0,*)'tslb(ipr)=',ipr,tslb(ipr,:) - write (0,*)'smois(ipr)=',ipr,smois(ipr,:) + write (0,*)'tslb(i)=',i,tslb(i,:) + write (0,*)'smois(i)=',i,smois(i,:) + write (0,*)'wetness(i)=',i,wetness(i) + enddo endif ! debug_print end subroutine rucinit diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index a8c39defe..061979d63 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -15,6 +15,14 @@ type = integer intent = in optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [isot] standard_name = soil_type_dataset_choice long_name = soil type dataset choice @@ -39,6 +47,222 @@ type = integer intent = in optional = F +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_init] + standard_name = flag_for_first_time_step + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsoil_ruc] + standard_name = soil_vertical_dimension_for_land_surface_model + long_name = number of soil layers internal to land surface model + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[kice] + standard_name = ice_vertical_dimension + long_name = vertical loop extent for ice levels, start at 1 + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsm_ruc] + standard_name = flag_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stype] + standard_name = soil_type_classification_real + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vtype] + standard_name = vegetation_type_classification_real + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_lnd] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_wat] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = total soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zs] + standard_name = depth_of_soil_levels_for_land_surface_model + long_name = depth of soil levels for land surface model + units = m + dimensions = (soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = out + optional = F +[sh2o] + standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model + long_name = volume fraction of unfrozen soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[smfrkeep] + standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model + long_name = volume fraction of frozen soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[tslb] + standard_name = soil_temperature_for_land_surface_model + long_name = soil temperature for land surface model + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[smois] + standard_name = volume_fraction_of_soil_moisture_for_land_surface_model + long_name = volumetric fraction of soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[wetness] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsice] + standard_name = internal_ice_temperature + long_name = sea ice internal temperature + units = K + dimensions = (horizontal_dimension,ice_vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -154,7 +378,7 @@ dimensions = (soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - intent = inout + intent = in optional = F [t1] standard_name = air_temperature_at_lowest_model_layer diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 6984602bc..1a1a8eefa 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -3,7 +3,7 @@ !>\defgroup mod_sfcsub GFS sfcsub Module -!!\ingroup Noah_LSM +!!\ingroup LSMs !> @{ !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). @@ -37,6 +37,18 @@ module sfccyc_module integer :: soil_type_landice integer :: num_threads ! +! + contains + + function message(prefix,index) + implicit none + character(len=*), intent(in) :: prefix + integer, intent(in) :: index + ! Safety measure: prevent writing out of bounds, use a longer string than 8 characters + character(len=16) :: message + write(message,fmt='(a,a,i0)') trim(prefix), '-', index + end function message + end module sfccyc_module !>\ingroup mod_GFS_phys_time_vary @@ -304,7 +316,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx (for noah lsm) +!clu [-1l/+1l] relax tsfsmx parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, & tsfjmx=273.16,tsfjmn=173.0) @@ -389,7 +401,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(snwmin=5.0,snwmax=100.) real (kind=kind_io8), parameter :: ten=10.0, one=1.0 ! -! coeeficients of blending forecast and interpolated clim +! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) ! 1.0 = use of forecast ! 0.0 = replace with interpolated analysis @@ -400,10 +412,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! --------------------------------------------------------- ! surface temperature forecast analysis ! surface temperature forecast forecast (over sea ice) -! albedo analysis analysis +! albedo forecast/analysis analysis ! sea-ice analysis analysis -! snow analysis forecast (over sea ice) -! roughness analysis forecast +! snow forecast/analysis forecast (over sea ice) +! roughness forecast/analysis forecast ! plant resistance analysis analysis ! soil wetness (layer) weighted average analysis ! soil temperature forecast analysis @@ -421,7 +433,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! max snow albedo analysis analysis ! slope type analysis analysis ! liquid soil wetness analysis-weighted analysis -! actual snow depth analysis-weighted analysis +! actual snow depth forecast/analysis-weighted analysis ! ! note: if analysis file is not given, then time interpolated climatology ! is used. if analyiss file is given, it will be used as far as the @@ -538,9 +550,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! rec. 1 label ! rec. 2 date record ! rec. 3 tsf -! rec. 4 soilm(two layers) ----> 4 layers +! rec. 4 soilm(lsoil) ! rec. 5 snow -! rec. 6 soilt(two layers) ----> 4 layers +! rec. 6 soilt(lsoil) ! rec. 7 tg3 ! rec. 8 zor ! rec. 9 cv @@ -565,7 +577,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! rec. 25 tprcp ! rec. 26 srflag ! rec. 27 swd -! rec. 28 slc (4 layers) +! rec. 28 slc (lsoil) ! rec. 29 vmn ! rec. 30 vmx ! rec. 31 slp @@ -1245,50 +1257,26 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get soil temp and moisture (after all the qcs are completed) ! + !-- soil moisture if(fnsmcc(1:8).eq.' ') then call getsmc(wetclm,len,lsoil,smcclm,me) endif - call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, + do k=1,lsoil + call qcmxmn(message('stc',k),smcclm(1,k),sliclm,snoclm,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcclm(3:4) - if(lsoil > 2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if (fnstcc(1:8) == ' ') then + enddo + !-- soil temperature + if(fnstcc(1:8).eq.' ') then call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif - call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, + do k=1,lsoil + call qcmxmn(message('stc',k),stcclm(1,k),sliclm,snoclm,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcclm(3:4) - if (lsoil > 2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1346,17 +1334,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisclm',aisclm,sliclm,snoclm,len) call monitr('snoclm',snoclm,sliclm,snoclm,len) call monitr('scvclm',scvclm,sliclm,snoclm,len) - call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) - call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) - call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) - call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) -!clu [+4l] add smcclm(3:4) and stcclm(3:4) - if(lsoil.gt.2) then - call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) - call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) - call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) - call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) - endif + do k=1,lsoil + call monitr(message('smcclm',k),smcclm(1,k),sliclm,snoclm,len) + call monitr(message('stcclm',k),stcclm(1,k),sliclm,snoclm,len) + enddo call monitr('tg3clm',tg3clm,sliclm,snoclm,len) call monitr('zorclm',zorclm,sliclm,snoclm,len) ! if (gaus) then @@ -1655,47 +1636,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & if(fnsmca(1:8) == ' ' .and. fnsmcc(1:8) == ' ') then call getsmc(wetanl,len,lsoil,smcanl,me) endif - call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, + !-- soil moisture + do k=1,lsoil + call qcmxmn(message('smca',k),smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if (lsoil > 2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if(fnstca(1:8) == ' ') then + enddo + !-- soil temperature + if(fnstca(1:8).eq.' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif - call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, + do k=1,lsoil + call qcmxmn(message('stca',k),stcanl(1,1),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if (lsoil > 2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1741,17 +1698,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('aisanl',aisanl,slianl,snoanl,len) call monitr('snoanl',snoanl,slianl,snoanl,len) call monitr('scvanl',scvanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - endif + do k=1,lsoil + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) + enddo call monitr('tg3anl',tg3anl,slianl,snoanl,len) call monitr('zoranl',zoranl,slianl,snoanl,len) ! if (gaus) then @@ -1920,44 +1870,22 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, ! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, ! & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, +!-- soil moisture forecast + do k=1,lsoil + call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs, + & snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcfcs(3:4) - if (lsoil > 2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, + enddo +!-- soil temperature forecast + do k=1,lsoil + call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs, + & snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcfcs(3:4) - if (lsoil > 2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -2003,17 +1931,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albfcs',albfcs,slifcs,snofcs,len) call monitr('aisfcs',aisfcs,slifcs,snofcs,len) call monitr('snofcs',snofcs,slifcs,snofcs,len) - call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) - call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) - call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) - call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) -!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if (lsoil > 2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) - endif + do k=1,lsoil + call monitr(message('smcfcs',k),smcfcs(1,k),slifcs,snofcs,len) + call monitr(message('stcfcs',k),stcfcs(1,k),slifcs,snofcs,len) + enddo call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) call monitr('zorfcs',zorfcs,slifcs,snofcs,len) ! if (gaus) then @@ -2155,41 +2076,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, ! & rla,rlo,len,kqcm,percrit,lgchek,me) ! endif - call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, + do k=1,lsoil + call qcmxmn(message('stcm',k),stcanl(1,k),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, + enddo + do k=1,lsoil + call qcmxmn(message('smcm',k),smcanl(1,k),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if (lsoil > 2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif + enddo kqcm = 1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -2272,16 +2170,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albanl',albanl,slianl,snoanl,len) call monitr('aisanl',aisanl,slianl,snoanl,len) call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) + do k=1,lsoil + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) + enddo if (lsoil > 2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) call monitr('tg3anl',tg3anl,slianl,snoanl,len) call monitr('zoranl',zoranl,slianl,snoanl,len) endif @@ -2358,17 +2251,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) call monitr('aisdif',aisfcs,slianl,snoanl,len) call monitr('snodif',snofcs,slianl,snoanl,len) - call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) -!clu [+4l] add smcfcs(3:4) and stc(3:4) - if (lsoil > 2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) - endif + do k=1,lsoil + call monitr(message('smcanl',k),smcfcs(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcfcs(1,k),slianl,snoanl,len) + enddo call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) ! if (gaus) then @@ -5433,7 +5319,7 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & & fldsmx,fldsmn,epsfld,percrit & integer, parameter :: mmprt=2 ! - character*8 ttl + character(len=*) ttl logical iceflg(len) real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo logical lgchek diff --git a/physics/tracer_sanitizer.F90 b/physics/tracer_sanitizer.F90 new file mode 100644 index 000000000..668cf6edd --- /dev/null +++ b/physics/tracer_sanitizer.F90 @@ -0,0 +1,113 @@ +module tracer_sanitizer + + use machine, only : kind_phys + + implicit none + + private + + public :: tracer_sanitizer_init, tracer_sanitizer_run, tracer_sanitizer_finalize + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: qvmin = 1.0E-6_kind_phys + +contains + + subroutine tracer_sanitizer_init() + end subroutine tracer_sanitizer_init + +!> \section arg_table_tracer_sanitizer_run Argument Table +!! \htmlinclude tracer_sanitizer_run.html +!! + subroutine tracer_sanitizer_run(tracers, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & + ntlnc, ntinc, ntrnc, ntsnc, ntgnc, errmsg, errflg) + + ! Interface variables + integer, intent(in ) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, & + ntlnc, ntinc, ntrnc, ntsnc, ntgnc + real(kind=kind_phys), intent(inout) :: tracers(:,:,:) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Water vapor specific humidity + if (ntqv>0) then + where (tracers(:,:,ntqv)0) then + where (tracers(:,:,ntcw)0) then + where (tracers(:,:,ntlnc)==zero) + tracers(:,:,ntlnc)=zero + end where + end if + end if + + ! Ice water + if (ntiw>0) then + where (tracers(:,:,ntiw)0) then + where (tracers(:,:,ntinc)==zero) + tracers(:,:,ntinc)=zero + end where + end if + end if + + ! Rain water + if (ntrw>0) then + where (tracers(:,:,ntrw)0) then + where (tracers(:,:,ntrnc)==zero) + tracers(:,:,ntrnc)=zero + end where + end if + end if + + ! Snow + if (ntsw>0) then + where (tracers(:,:,ntsw)0) then + where (tracers(:,:,ntsnc)==zero) + tracers(:,:,ntsnc)=zero + end where + end if + end if + + ! Graupel + if (ntgl>0) then + where (tracers(:,:,ntgl)0) then + where (tracers(:,:,ntgnc)==zero) + tracers(:,:,ntgnc)=zero + end where + end if + end if + + end subroutine tracer_sanitizer_run + + subroutine tracer_sanitizer_finalize() + end subroutine tracer_sanitizer_finalize + +end module tracer_sanitizer \ No newline at end of file diff --git a/physics/tracer_sanitizer.meta b/physics/tracer_sanitizer.meta new file mode 100644 index 000000000..e41d5d03d --- /dev/null +++ b/physics/tracer_sanitizer.meta @@ -0,0 +1,124 @@ +[ccpp-table-properties] + name = tracer_sanitizer + type = scheme + dependencies = machine.F + +######################################################################## + +[ccpp-arg-table] + name = tracer_sanitizer_run + type = scheme +[tracers] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[ntqv] + standard_name = index_for_water_vapor + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntlnc] + standard_name = index_for_liquid_cloud_number_concentration + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntinc] + standard_name = index_for_ice_cloud_number_concentration + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgnc] + standard_name = index_for_graupel_number_concentration + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index f573c8776..c47079992 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,4 +1,4 @@ -!!23456 +! module sso_coorde ! ! specific to COORDE-2019 project OGW switches/sensitivity @@ -31,7 +31,8 @@ subroutine cires_ugwp_driver_v0(me, master, ! (similar to WAM-2017) !----------------------------------------------------------- use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv + use physcons, only : con_cp, con_g, con_rd, con_rv, & + con_omega use ugwp_wmsdis_init, only : tamp_mpa, ilaunch use sso_coorde, only : pgwd, pgwd4, debugprint @@ -121,6 +122,7 @@ subroutine cires_ugwp_driver_v0(me, master, & SIGMA, GAMM, ELVMAX, & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, & cdmbgwd(1:2), me, master, rdxzb, + & con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & du3dt_mtb, du3dt_ogw, du3dt_tms) ! @@ -287,7 +289,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, & DUSFC, DVSFC, xlatd, sinlat, coslat, sparea, - $ cdmbgwd, me, master, rdxzb, + & cdmbgwd, me, master, rdxzb, con_g, con_omega, & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & dudt_mtb, dudt_ogw, dudt_tms) !---------------------------------------- @@ -341,6 +343,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys), intent(in) :: ELVMAXD(IM), THETA(IM) real(kind=kind_phys), intent(in) :: vSIGMA(IM), vGAMMA(IM) real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) + + real(kind=kind_phys), intent(in) :: con_g, con_omega !output -phys-tend real(kind=kind_phys),dimension(im,km),intent(out) :: @@ -1066,6 +1070,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, + & con_g, con_omega, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 new file mode 100644 index 000000000..fda887f3e --- /dev/null +++ b/physics/unified_ugwp.F90 @@ -0,0 +1,736 @@ +!> \file unified_ugwp.F90 +!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: +!! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f +!! b) the v0 cires ugwp non-stationary GWD scheme +!! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: +!! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales +!! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) +!! b) small-scale gravity wave drag scheme -- active typically in stable PBL at horizontal grid resolutions down to ~1km +!! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) +!! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km +!! (Beljaars et al, 2004 \cite beljaars_et_al_2004) +!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) +!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. +!! Unified Formalism: +!! 1. GW Sources: Stochastic and physics based mechanisms for GW-excitations in the lower atmosphere, calibrated by the high-res analyses/forecasts, and observations (3 types of GW sources: orography, convection, fronts/jets). +!! 2. GW Propagation: Unified solver for "propagation, dissipation and breaking" excited from all type of GW sources. +!! 3. GW Effects: Unified representation of GW impacts on the "resolved" flow for all sources (energy-balanced schemes for momentum, heat and mixing). +!! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf +!! +!! The unified_ugwp scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD +!! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag +!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only +!! Note that only one "large-scale" scheme can be activated at a time. +!! + +module unified_ugwp + + use machine, only: kind_phys + + use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + + use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp + + use gwdps, only: gwdps_run + + use drag_suite, only: drag_suite_run + + use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 + + use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 + + ! use cires_ugwp_ngw_utils, only: tau_limb_advance + + use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 + + implicit none + + private + + public unified_ugwp_init, unified_ugwp_run, unified_ugwp_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the unified UGWP +!> \section arg_table_unified_ugwp_init Argument Table +!! \htmlinclude unified_ugwp_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & + con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & + do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, errmsg, errflg) + +!---- initialization of unified_ugwp + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + character(len=*), intent (in) :: input_nml_file(:) + integer, intent (in) :: logunit + integer, intent(in) :: jdat(8) + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + real(kind=kind_phys), intent (in) :: ak(:), bk(:) + real(kind=kind_phys), intent (in) :: dtp + real(kind=kind_phys), intent (in) :: cdmbgwd(4), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes + real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in + real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth + logical, intent (in) :: do_ugwp + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only + + character(len=*), intent (in) :: fn_nml2 + !character(len=*), parameter :: fn_nml='input.nml' + + integer :: ios + logical :: exists + real :: dxsg + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + ! Test to make sure that at most only one large-scale/blocking + ! orographic drag scheme is chosen + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & + do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & + do_ugwp_v1_orog_only)) .or. & + (do_gsl_drag_ls_bl.and.(do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v1.and.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: Only one large-scale& + &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& + &do_gsl_drag_ls_bl,do_ugwp_v1 or & + &do_ugwp_v1_orog_only) can be chosen" + errflg = 1 + return + + end if + + + if (is_initialized) return + + + if ( do_ugwp_v0 ) then + ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) + if (cdmbgwd(3) > 0.0) then + call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + else + write(errmsg,'(*(a))') "Logic error: cires_ugwp_mod_init called but & + &do_ugwp_v0 is true and cdmbgwd(3) <= 0" + errflg = 1 + return + end if + end if + + + if ( do_ugwp_v1 ) then + call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & + con_p0, dtp, cdmbgwd(1:2), cgwf, pa_rf_in, & + tau_rf_in, errmsg, errflg) + end if + + is_initialized = .true. + + end subroutine unified_ugwp_init + + +! ----------------------------------------------------------------------- +! finalize of unified_ugwp (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP + +!> \section arg_table_unified_ugwp_finalize Argument Table +!! \htmlinclude unified_ugwp_finalize.html +!! + + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) + + implicit none +! + logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() + + if ( do_ugwp_v1 ) call cires_ugwp_finalize() + + is_initialized = .false. + + end subroutine unified_ugwp_finalize + + +! ----------------------------------------------------------------------- +! originally from ugwp_driver_v0.f +! driver of cires_ugwp (_driver) +! ----------------------------------------------------------------------- +! driver is called after pbl & before chem-parameterizations +! ----------------------------------------------------------------------- +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +! ----------------------------------------------------------------------- +!>@brief These subroutines and modules execute the CIRES UGWP Version 0 +!>\defgroup unified_ugwp_run Unified Gravity Wave Physics General Algorithm +!> @{ +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! +!! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. +!! +!> \section arg_table_unified_ugwp_run Argument Table +!! \htmlinclude unified_ugwp_run.html +!! +!> \section gen_unified_ugwp CIRES UGWP Scheme General Algorithm +!! @{ + subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & + lonr, oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss,dx,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl,dusfc_ss, & + dvsfc_ss,dusfc_fd,dvsfc_fd,dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,br1,hpbl,slmsk, & + do_tofd, ldiag_ugwp, cdmbgwd, jdat, xlat, xlat_d, sinlat, coslat, area, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & + del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & + dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt, dvdt, dtdt, rdxzb, con_g, con_omega, con_pi, con_cp, con_rd, con_rv, & + con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr + integer, intent(in) :: gwd_opt + integer, intent(in), dimension(im) :: kpbl + real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,oa4ss,ol4ss,dx + logical, intent(in) :: flag_for_gwd_generic_tend + ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii + real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 + real(kind=kind_phys), intent(in) :: dtp, fhzero, cdmbgwd(4) + integer, intent(in) :: jdat(8) + logical, intent(in) :: do_tofd, ldiag_ugwp + +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + + real(kind=kind_phys), intent(in) :: br1(im), & + & hpbl(im), & + & slmsk(im) + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + + ! These arrays are only allocated if ldiag=.true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw + logical, intent(in) :: ldiag3d, lssav + + ! These arrays only allocated if ldiag_ugwp = .true. + real(kind=kind_phys), intent(out), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms + + real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt + + real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & + con_rv, con_rerth, con_fvirt + + real(kind=kind_phys), intent(in), dimension(im) :: rain + + integer, intent(in) :: ntke + real(kind=kind_phys), intent(in), dimension(:,:) :: q_tke, dqdt_tke + + logical, intent(in) :: lprnt + integer, intent(in) :: ipr + + ! flags for choosing combination of GW drag schemes to run + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i, k + real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis + real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt + ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init + real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 + ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) + real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. + real(kind=kind_phys), parameter :: fw1_tau=1.0 + integer :: nmtvr_temp + + real(kind=kind_phys), dimension(:,:), allocatable :: tke + real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1 + + real(kind=kind_phys) :: inv_g + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers + real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces + + + ! ugwp_v1 local variables + integer :: y4, month, day, ddd_ugwp, curdate, curday + integer :: hour + real(kind=kind_phys) :: hcurdate, hcurday, fhour, fhrday + integer :: kdtrest + integer :: curday_ugwp + integer :: curday_save=20150101 + logical :: first_qbo=.true. + real :: hcurday_save =20150101.00 + save first_qbo, curday_save, hcurday_save + + + ! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 + real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! 1) ORO stationary GWs + ! ------------------ + + zlwb(:) = 0. + + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme + ! Note: In case of GSL drag_suite, this includes ss and tofd + + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd ) then + + call drag_suite_run(im,levs,dvdt,dudt,dtdt,ugrs,vgrs,tgrs,q1, & + kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & + kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & + ol4ss,theta,sigma,gamma,elvmax,dtaux2d_ls, & + dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss, & + dtauy2d_ss,dtaux2d_fd,dtauy2d_fd,dusfcg, & + dvsfcg,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & + con_fvirt,con_pi,lonr, & + cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & + do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & + errmsg,errflg) + + end if + + if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then + + ! Valery's TOFD + ! topo paras + ! w/ orographic effects + if(nmtvr == 14)then + ! calculate sgh30 for TOFD + sgh30 = abs(oro - oro_uf) + ! w/o orographic effects + else + sgh30 = 0. + endif + + inv_g = 1./con_g + zmeti = phii*inv_g + zmet = phil*inv_g + + call gwdps_oro_v1 (im, levs, lonr, do_tofd, & + Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & + prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & + clx, theta, sigma, gamma, elvmax, & + con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & + con_rerth, con_fvirt, sgh30, DUSFCg, DVSFCg, & + xlat_d, sinlat, coslat, area,cdmbgwd(1:2), me, & + master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, du3dt_mtb, du3dt_ogw, du3dt_tms) + + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo + + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + + ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary + if ( nmtvr == 24 ) then ! gwd_opt = 2, 22, 3, or 33 + nmtvr_temp = 14 + else + nmtvr_temp = nmtvr + end if + + call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & + ugrs, vgrs, tgrs, q1, & + kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & + hprime, oc, oa4, clx, theta, sigma, gamma, & + elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, lonr, & + nmtvr_temp, cdmbgwd, me, lprnt, ipr, rdxzb, & + errmsg, errflg) + if (errflg/=0) return + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + if (ldiag_ugwp) then + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + end if + + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + Pdudt(i,k)*dtp + ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + Pdvdt(i,k)*dtp + ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + Pdtdt(i,k)*dtp + enddo + enddo + endif + + end if + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Begin non-stationary GW schemes + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! + ! ugwp_v0 non-stationary GW drag + ! + if (do_ugwp_v0) then + + if (cdmbgwd(3) > 0.0) then + + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing + call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + + if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then + if (cdmbgwd(4) > 0.0) then + allocate(turb_fac(im)) + do i=1,im + turb_fac(i) = 0.0 + enddo + if (ntke > 0) then + allocate(tke(im,levs)) + allocate(tem(im)) + tke(:,:) = q_tke(:,:) + dqdt_tke(:,:) * dtp + tem(:) = 0.0 + do k=1,(levs+levs)/3 + do i=1,im + turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) + tem(i) = tem(i) + del(i,k) + enddo + enddo + do i=1,im + turb_fac(i) = turb_fac(i) / tem(i) + enddo + deallocate(tke) + deallocate(tem) + endif + rfac = 86400000 / dtp + do i=1,im + tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + enddo + deallocate(turb_fac) + endif + do i=1,im + tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) + enddo + endif + + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_ngw, me, master, kdt) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) + !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) + !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) + !dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + enddo + enddo + + else ! .not.(cdmbgwd(3) > 0.0) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = Pdtdt(i,k) + gw_dudt(i,k) = Pdudt(i,k) + gw_dvdt(i,k) = Pdvdt(i,k) + gw_kdis(i,k) = Pkdis(i,k) + enddo + enddo + + endif ! cdmbgwd(3) > 0.0 + + if (pogw == 0.0) then + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + endif + +#if 0 + !============================================================================= + ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving + ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" + !============================================================================= + ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies + !------------------------------------------------------------------------------ + do k=1,levs + do i=1,im + ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + enddo + enddo + + call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & + del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) + gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked + gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked + gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked +#endif + + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_cgw(i,k) = ldu3dt_cgw(i,k) + (gw_dudt(i,k) - Pdudt(i,k))*dtp + ldv3dt_cgw(i,k) = ldv3dt_cgw(i,k) + (gw_dvdt(i,k) - Pdvdt(i,k))*dtp + ldt3dt_cgw(i,k) = ldt3dt_cgw(i,k) + (gw_dtdt(i,k) - Pdtdt(i,k))*dtp + enddo + enddo + endif + + end if ! do_ugwp_v0 + + + ! + ! ugwp_v1 non-stationary GW drag + ! + if (do_ugwp_v1) then + +! -------- +! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing +! ---------------------------------------------- +!-------- +! GMAO GEOS-5/MERRA GW-forcing lat-dep +!-------- + call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) + + y4 = jdat(1); month = jdat(2); day = jdat(3) ; hour = jdat(5) + + ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. + fhour = (kdt-1)*dtp/3600. + fhrday = fhour/24. - nint(fhour/24.) + fhour = fhrday*24. + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp + curday = y4*10000 + month*100 + day + hcurdate = float(curdate) + fhrday + hcurday = float(curday) + fhrday +! + if (mod(fhour,fhzero) == 0 .or. first_qbo) then + + ! call tau_limb_advance(me, master, im, levs, ddd_ugwp, curdate, & + ! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) + + if (first_qbo) kdtrest = kdt + first_qbo = .false. + curday_save = curday + hcurday_save= hcurday + endif + + ! tau_ngw = fw1_tau*tau_ngw + tau_sat*(1.-fw1_tau) + +! goto 111 +! if (mod(fhour,fhzero) == 0 .or. first_qbo) then + +! call tau_qbo_advance(me, master, im, levs, ddd_ugwp, curdate, & +! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, j1_qbo, j2_qbo, & +! ddy_j1qbo, ddy_j2qbo, tau_sat, tau_qbo, uqbo, ax_qbo, kdt ) + + +! if (me == master) then +! print *, ' curday_save first_qbo ', curday, curday_save, kdt +! print *, ' hcurdays ', hcurdate, float(hour)/24. +! print *, jdat(5), jdat(6), jdat(7), (kdt-1)*dtp/3600., ' calendar ' +!! print *, ' curday curday_ugwp first_qbo ', hcurday, first_qbo +!! print *, ' vay_tau-limb U' , maxval(uqbo), minval(uqbo) +!! print *, ' vay_tau-limb TS' , maxval(tau_sat), minval(tau_sat) +!! print *, ' vay_tau-limb TQ' , maxval(tau_qbo), minval(tau_qbo) +! endif + + +! if (first_qbo) kdtrest = kdt +! first_qbo = .false. +! curday_save = curday +! hcurday_save= hcurday +! endif + + + + +! if (mod(kdt, 720) == 0 .and. me == master ) then +! print *, ' vay_qbo_U' , maxval(uqbo), minval(uqbo) , kdt +! endif + +! wqbo = dtp/taurel +! do k =1, levs +!! sdexpz = wqbo*vert_qbo(k) +! sdexpz = 0.25*vert_qbo(k) +! do i=1, im +!! if (dexpy(i) > 0.0) then +! dforc = 0.25 +!! ugrs(i,k) = ugrs(i,k)*(1.-dforc) + dforc*uqbo(i,levs+1-k) +!! tgrs(i,k) = tgrs(i,k)*(1.-dforc) + dforc*tqbo(i,levs+1-k) +!! endif +! enddo +! enddo + +! 111 continue + + + call cires_ugwp_solv2_v1(im, levs, dtp, & + tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + con_g, con_cp, con_rd, con_rv, con_omega, & + con_pi, con_fvirt, & + gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & + tauabs, wrms, trms, tau_ngw, me, master, kdt) + + if (me == master .and. kdt < 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 in ugwp_driver_v0 ' + write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + endif + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) + !+(uqbo(i,levs+1-k)-ugrs(i,k))/21600. + gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k) ! + pogw*Pkdis(i,k) + enddo + enddo + + + + + if (pogw == 0.0) then +! zmtb = 0.; zogw =0. + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + endif + +! return + +!============================================================================= +! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving +! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" +!============================================================================= +! +! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies +!------------------------------------------------------------------------------ + +! ed_dudt(:,:) = 0.0 ; ed_dvdt(:,:) = 0.0 ; ed_dtdt(:,:) = 0.0 + + + +! call edmix_ugwp_v1(im, levs, dtp, & +! tgrs, ugrs, vgrs, q1, del, & +! prsl, prsi, phil, prslk, & +! gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & +! ed_dudt, ed_dvdt, ed_dTdt, +! me, master, kdt ) + +! do k=1,levs +! do i=1,im +! gw_dtdt(i,k) = gw_dtdt(i,k) + ed_dtdt(i,k)*pked +! gw_dvdt(i,k) = gw_dvdt(i,k) + ed_dvdt(i,k)*pked +! gw_dudt(i,k) = gw_dudt(i,k) + ed_dudt(i,k)*pked +! enddo +! enddo + + + end if ! do_ugwp_v1 + + + end subroutine unified_ugwp_run +!! @} +!>@} +end module unified_ugwp diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta new file mode 100644 index 000000000..675a68edd --- /dev/null +++ b/physics/unified_ugwp.meta @@ -0,0 +1,1360 @@ +[ccpp-table-properties] + name = unified_ugwp + type = scheme + dependencies = machine.F,cires_ugwp_module.F90,ugwp_driver_v0.F,cires_ugwp_triggers.F90 + dependencies = cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90 + dependencies = cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90 + dependencies = cires_vert_wmsdis.F90,cires_ugwp_module_v1.F90,cires_ugwp_triggers_v1.F90 + dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_solv2_v1_mod.F90 + dependencies = cires_ugwp_orolm97_v1.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 + dependencies = gwdps.f,drag_suite.F90 + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for opening namelist file + units = none + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=* + intent = in + optional = F +[logunit] + standard_name = iounit_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in + optional = F +[fn_nml2] + standard_name = namelist_filename + long_name = namelist filename for ugwp + units = none + dimensions = () + type = character + kind = len=* + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[latr] + standard_name = number_of_latitude_points + long_name = number of global points in y-dir (j) along the meridian + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ak] + standard_name = a_parameter_of_the_hybrid_coordinate + long_name = a parameter for sigma pressure level calculations + units = Pa + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[bk] + standard_name = b_parameter_of_the_hybrid_coordinate + long_name = b parameter for sigma pressure level calculations + units = none + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[cgwf] + standard_name = multiplication_factors_for_convective_gravity_wave_drag + long_name = multiplication factor for convective GWD + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[pa_rf_in] + standard_name = pressure_cutoff_for_rayleigh_damping + long_name = pressure level from which Rayleigh Damping is applied + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tau_rf_in] + standard_name = time_scale_for_rayleigh_damping + long_name = time scale for Rayleigh damping in days + units = d + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_p0] + standard_name = standard_atmospheric_pressure + long_name = standard atmospheric pressure + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_finalize + type = scheme +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_run + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fhzero] + standard_name = hours_between_clearing_of_diagnostic_buckets + long_name = hours between clearing of diagnostic buckets + units = h + dimensions = () + type = real + kind = kind_phys +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[oro] + standard_name = orography + long_name = orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oro_uf] + standard_name = orography_unfiltered + long_name = unfiltered orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of topographic variables in GWD + units = count + dimensions = () + type = integer + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_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 = inout + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_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 subgrid orography 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 +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_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 + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ls] + standard_name = y_momentum_tendency_from_large_scale_gwd + long_name = y momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_bl] + standard_name = x_momentum_tendency_from_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_bl] + standard_name = y_momentum_tendency_from_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ss] + standard_name = x_momentum_tendency_from_small_scale_gwd + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ss] + standard_name = y_momentum_tendency_from_small_scale_gwd + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_fd] + standard_name = x_momentum_tendency_from_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_fd] + standard_name = y_momentum_tendency_from_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_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 +[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 +[do_tofd] + standard_name = turb_oro_form_drag_flag + long_name = flag for turbulent orographic form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_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 +[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 +[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 +[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 +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gw_kdis] + standard_name = eddy_mixing_due_to_ugwp + long_name = eddy mixing due to UGWP + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + 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 +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + 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 + units = m + 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 wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_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 + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_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 +[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 +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[q_tke] + standard_name = turbulent_kinetic_energy + long_name = turbulent kinetic energy + units = J + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqdt_tke] + standard_name = tendency_of_turbulent_kinetic_energy_due_to_model_physics + long_name = turbulent kinetic energy tendency due to model physics + units = J s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[ldu3dt_ogw] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in x wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_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_cgw] + standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in x wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_cgw] + standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in y wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_cgw] + standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag + long_name = cumulative change in temperature due to convective gravity wave drag + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_gravity_wave_drag_tendency + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/unified_ugwp_post.F90 b/physics/unified_ugwp_post.F90 new file mode 100644 index 000000000..3af459d76 --- /dev/null +++ b/physics/unified_ugwp_post.F90 @@ -0,0 +1,77 @@ +!> \file unified_ugwp_post.F90 +!! This file contains +module unified_ugwp_post + +contains + +!>\defgroup unified_ugwp_post unified_UGWP Scheme Post +!! @{ + + subroutine unified_ugwp_post_init () + end subroutine unified_ugwp_post_init + +!>@brief The subroutine initializes the unified UGWP + +!> \section arg_table_unified_ugwp_post_run Argument Table +!! \htmlinclude unified_ugwp_post_run.html +!! + subroutine unified_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & + gw_dtdt, gw_dudt, gw_dvdt, tau_tofd, tau_mtb, tau_ogw, & + tau_ngw, zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & + tot_zmtb, tot_zlwb, tot_zogw, & + tot_tofd, tot_mtb, tot_ogw, tot_ngw, & + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtf + logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics + + real(kind=kind_phys), intent(in), dimension(:) :: zmtb, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(:) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_zmtb, tot_zlwb, tot_zogw + real(kind=kind_phys), intent(in), dimension(:,:) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zmtb + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *tau_tofd + tot_mtb = tot_mtb + dtf *tau_mtb + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_mtb + du3dt_tms = du3dt_tms + dtf *dudt_tms + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *gw_dudt + dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt + endif + + dtdt = dtdt + gw_dtdt + dudt = dudt + gw_dudt + dvdt = dvdt + gw_dvdt + + end subroutine unified_ugwp_post_run + + subroutine unified_ugwp_post_finalize () + end subroutine unified_ugwp_post_finalize + +!! @} +end module unified_ugwp_post diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta new file mode 100644 index 000000000..85a6bff8e --- /dev/null +++ b/physics/unified_ugwp_post.meta @@ -0,0 +1,311 @@ +[ccpp-table-properties] + name = unified_ugwp_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = unified_ugwp_post_run + type = scheme +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dudt] + standard_name = tendency_of_x_wind_due_to_ugwp + long_name = zonal wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_tofd] + standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = momentum flux or stress due to TOFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tau_mtb] + standard_name = instantaneous_momentum_flux_due_to_mountain_blocking_drag + long_name = momentum flux or stress due to mountain blocking drag + units = Pa + dimensions = (horizontal_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 +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + 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 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_mtb] + standard_name = instantaneous_change_in_x_wind_due_to_mountain_blocking_drag + long_name = instantaneous change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = 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 = in + optional = F +[dudt_tms] + standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = instantaneous change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_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