From 8364e618a0e02bde9cf50fbda12b039794c40e65 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 6 Nov 2020 15:35:19 -0700 Subject: [PATCH 01/67] Thompson MP in GP. Not complete. --- physics/GFS_rrtmgp_pre.F90 | 20 +- physics/GFS_rrtmgp_pre.meta | 18 + physics/GFS_rrtmgp_thompsonmp_pre.F90 | 358 ++++++++++++++++ physics/GFS_rrtmgp_thompsonmp_pre.meta | 555 +++++++++++++++++++++++++ physics/module_SGSCloud_RadPre.F90 | 49 --- 5 files changed, 942 insertions(+), 58 deletions(-) create mode 100644 physics/GFS_rrtmgp_thompsonmp_pre.F90 create mode 100644 physics/GFS_rrtmgp_thompsonmp_pre.meta diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 0e5d65f5c..f4542dffb 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -143,10 +143,10 @@ end subroutine GFS_rrtmgp_pre_init !> \section arg_table_GFS_rrtmgp_pre_run !! \htmlinclude GFS_rrtmgp_pre_run.html !! - subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, fhswr, & - fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, active_gases_array, & - con_eps, con_epsm1, con_fvirt, con_epsqs, & - raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, tv_lay, relhum, tracer, & + subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, fhswr, & + fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, active_gases_array, con_eps,& + con_epsm1, con_fvirt, con_epsqs, & + raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer,& gas_concentrations, errmsg, errflg) ! Inputs @@ -195,8 +195,10 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, real(kind_phys), dimension(nCol,nLev), intent(out) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer + q_lay, & ! Water-vapor mixing ratio (kg/kg) tv_lay, & ! Virtual temperature at model-layers - relhum ! Relative-humidity at model-layers + relhum, & ! Relative-humidity at model-layers + qs_lay ! Saturation vapor pressure at model-layers real(kind_phys), dimension(nCol,nLev+1), intent(out) :: & p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface @@ -209,8 +211,8 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, integer :: i, j, iCol, iBand, iSFC, iTOA, iLay logical :: top_at_1 real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o - real(kind_phys) :: es, qs, tem1, tem2 - real(kind_phys), dimension(nCol,nLev) :: o3_lay, q_lay + real(kind_phys) :: es, tem1, tem2 + real(kind_phys), dimension(nCol,nLev) :: o3_lay real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr ! Initialize CCPP error handling variables @@ -265,8 +267,8 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, do iCol=1,NCOL do iLay=1,nLev es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa - qs = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) - relhum(iCol,iLay) = max( 0._kind_phys, min( 1._kind_phys, max(con_epsqs, q_lay(iCol,iLay))/qs ) ) + qs_lay(iCol,iLay) = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) + relhum(iCol,iLay) = max( 0._kind_phys, min( 1._kind_phys, max(con_epsqs, q_lay(iCol,iLay))/qs_lay(iCol,iLay) ) ) tv_lay(iCol,iLay) = t_lay(iCol,iLay) * (1._kind_phys + con_fvirt*q_lay(iCol,iLay)) enddo enddo diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 7fa69c0f6..904c0e4e7 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -328,6 +328,24 @@ kind = kind_phys intent = out optional = F +[qs_lay] + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[q_lay] + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio + units = kg/kg + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [tracer] standard_name = chemical_tracers long_name = chemical tracers diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 new file mode 100644 index 000000000..f815ba0cc --- /dev/null +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -0,0 +1,358 @@ +! ######################################################################################## +! This module contains the interface between the THOMPSON macrophysics and the RRTMGP radiation +! schemes. Only compatable with Model%imp_physics = Model%imp_physics_thompson +! ######################################################################################## +module GFS_rrtmgp_thompsonmp_pre + use machine, only: & + kind_phys + use rrtmgp_aux, only: & + check_error_msg + use module_radiation_cloud_overlap, only: & + cmp_dcorr_lgth, & + get_alpha_exp + use module_mp_thompson, only: & + calc_effectRad, & + Nt_c + use module_mp_thompson_make_number_concentrations, only: & + make_IceNumber, & + make_DropletNumber, & + make_RainNumber + + ! Parameters specific to THOMPSONMP scheme. + real(kind_phys), parameter :: & + reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) + reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) + rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) + resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) + cllimit = 0.001 ! Lowest cloud fraction in GFDL MP scheme + + public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize + +contains + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_thompsonmp_pre_init() + end subroutine GFS_rrtmgp_thompsonmp_pre_init + + ! ###################################################################################### + ! ###################################################################################### +!! \section arg_table_GFS_rrtmgp_thompsonmp_pre_run +!! \htmlinclude GFS_rrtmgp_thompsonmp_pre_run.html +!! + subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice,& + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, yearlen, doSWrad, doLWrad, effr_in, julian, & + lat, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, & + qs_lay, q_lay, relhum, cld_frac_mg, con_pi, con_g, con_rd, con_epsq, iovr, iovr_dcorr, uni_cld, lmfshal, lmfdeep2, ltaerosol, & + iovr_exp,iovr_exprand, idcor, dcorr_con, idcor_con, idcor_hogan, idcor_oreopoulos, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, cloud_overlap_param, precip_overlap_param, de_lgth, & + deltaZb, errmsg, errflg) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid amount. + i_cldice, & ! cloud ice amount. + i_cldrain, & ! cloud rain amount. + i_cldsnow, & ! cloud snow amount. + i_cldgrpl, & ! cloud groupel amount. + i_cldtot, & ! cloud total amount. + i_cldliq_nc, & ! cloud liquid number concentration. + i_cldice_nc, & ! cloud ice number concentration. + i_twa, & ! water friendly aerosol. + yearlen, & ! Length of current year (365/366) WTF? + iovr, & ! Choice of cloud-overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + idcor, & ! Choice of method for decorrelation length computation + idcor_con, & ! Flag for decorrelation-length. Use constant value + idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) + idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + logical, intent(in) :: & + doSWrad, & ! Call SW radiation? + doLWrad, & ! Call LW radiation + effr_in, & ! Use cloud effective radii provided by model? + uni_cld, & ! + lmfshal, & ! + lmfdeep2, & ! + ltaerosol ! + real(kind_phys), intent(in) :: & + julian, & ! Julian day + con_pi, & ! Physical constant: pi + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_epsq, & ! Physical constant(?): Minimum value for specific humidity + dcorr_con ! Decorrelation-length (used if idcor = 0, default is idcor = 1) + real(kind_phys), dimension(nCol), intent(in) :: & + lat ! Latitude (radians) + real(kind_phys), dimension(nCol,nLev), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + t_lay, & ! Temperature (K) + qs_lay, & ! Saturation vapor pressure (Pa) + q_lay, & ! water-vapor mixing ratio (kg/kg) + relhum, & ! Relative humidity + p_lay, & ! Pressure at model-layers (Pa) + cld_frac_mg ! Cloud-fraction from MG scheme. WTF????? + real(kind_phys), dimension(nCol,nLev+1), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(nCol, nLev, nTracers),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! In/Outs + real(kind_phys), dimension(nCol,nLev), intent(inout) :: & + effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for ice cloud-particles (microns) + effrin_cldsnow ! Effective radius for snow cloud-particles (microns) + + ! Outputs + real(kind_phys), dimension(nCol),intent(out) :: & + de_lgth ! Decorrelation length + real(kind_phys), dimension(nCol,nLev),intent(out) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac, & ! Precipitation fraction + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param, & ! Precipitation overlap parameter + deltaZb ! Layer thickness (km) + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local variables + real(kind_phys) :: tem0, tem1, tem2, pfac, clwt, clwm, onemrh, xrc3 + real(kind_phys), dimension(nLev+1) :: hgtb + real(kind_phys), dimension(nLev) :: hgtc + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l,iSFC,iTOA + real(kind_phys), dimension(nCol,nLev) :: deltaP, deltaZ, rho, orho, re_cloud, re_ice,& + re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa + logical :: top_at_1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (doSWrad .or. doLWrad)) return + + ! What is vertical ordering? + top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) + if (top_at_1) then + iSFC = nLev + iTOA = 1 + else + iSFC = 1 + iTOA = nLev + endif + + ! Initialize outputs + cld_lwp(:,:) = 0.0 + cld_reliq(:,:) = 0.0 + cld_iwp(:,:) = 0.0 + cld_reice(:,:) = 0.0 + cld_rwp(:,:) = 0.0 + cld_rerain(:,:) = 0.0 + cld_swp(:,:) = 0.0 + cld_resnow(:,:) = 0.0 + + ! #################################################################################### + ! Pull out cloud information for THOMPSON MP scheme. + ! #################################################################################### + + ! Cloud condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + + ! + ! Compute effective radii for liquid/ice/snow using subgrid scale clouds + ! + + ! First, prepare cloud mixing-ratios and number concentrations for Calc_Re + rho = p_lay(1:nCol,1:nLev)/(con_rd*t_lay(1:nCol,1:nLev)) + orho = 1./rho + do iLay = 1, nLev + do iCol = 1, nCol + qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) + qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) + qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) + qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) + nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + if (ltaerosol) then + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) + else + nc_mp(iCol,iLay) = nt_c*orho(iCol,iLay) + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + endif + enddo + enddo + + ! Update number concentration, consistent with sub-grid clouds + do iLay = 1, nLev + do iCol = 1, nCol + if (ltaerosol .and. qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then + nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho(iCol,iLay), nwfa(iCol,iLay)) * orho(iCol,iLay) + endif + if (qi_mp(iCol,iLay) > 1.e-12 .and. ni_mp(iCol,iLay) < 100.) then + ni_mp(iCol,iLay) = make_IceNumber(qi_mp(iCol,iLay)*rho(iCol,iLay), t_lay(iCol,iLay)) * orho(iCol,iLay) + endif + enddo + enddo + + ! Call Thompson's subroutine to compute effective radii + do iCol=1,nCol + call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & + nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & + re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) + enddo + + ! Scale Thompson's effective radii from meter to micron and update global effective radii. + effrin_cldliq(1:nCol,1:nLev) = re_cloud(1:nCol,1:nLev)*1.e6 + effrin_cldice(1:nCol,1:nLev) = re_ice(1:nCol,1:nLev)*1.e6 + effrin_cldsnow(1:nCol,1:nLev) = re_snow(1:nCol,1:nLev)*1.e6 + + if (uni_cld) then + if (effr_in) then + cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) + cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) + cld_rerain(1:nCol,1:nLev) = rerain_def + cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) + else + cld_reliq(1:nCol,1:nLev) = reliq_def + cld_reice(1:nCol,1:nLev) = reice_def + cld_rerain(1:nCol,1:nLev) = rerain_def + cld_resnow(1:nCol,1:nLev) = resnow_def + endif ! effr_in + endif ! uni_cld + + ! Cloud-fraction + cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) + + ! Precipitation fraction (Hack. For now use cloud-fraction) + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) + + ! Condensate and effective size + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + if (cld_frac(iCol,iLay) .ge. cllimit) then + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = cld_condensate(iCol,iLay,1) * tem1 + cld_iwp(iCol,iLay) = cld_condensate(iCol,iLay,2) * tem1 + cld_rwp(iCol,iLay) = cld_condensate(iCol,iLay,3) * tem1 + cld_swp(iCol,iLay) = cld_condensate(iCol,iLay,4) * tem1 + endif + enddo + enddo + + ! #################################################################################### + ! Cloud (and precipitation) overlap + ! #################################################################################### + + ! + ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) + ! + do iCol=1,nCol + if (top_at_1) then + ! Layer thickness (km) + do iLay=1,nLev + deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(nLev+1) = 0._kind_phys + do iLay=nLev,1,-1 + hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = nLev, 1, -1 + pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & + abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) + hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) + enddo + ! Layer thickness between centers + do iLay = nLev-1, 1, -1 + deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) + enddo + deltaZb(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) + else + do iLay=nLev,1,-1 + deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(1) = 0._kind_phys + do iLay=1,nLev + hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = 1, nLev + pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & + abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) + hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) + enddo + ! Layer thickness between centers + do iLay = 2, nLev + deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) + enddo + deltaZb(iCol,1) = hgtc(1) - hgtb(1) + endif + enddo + + ! + ! Cloud decorrelation length + ! + if (idcor == idcor_hogan) then + call cmp_dcorr_lgth(nCol, abs(lat/con_pi), con_pi, de_lgth) + endif + if (idcor == idcor_oreopoulos) then + call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) + endif + if (idcor == idcor_con) then + de_lgth(:) = dcorr_con + endif + + ! + ! Cloud overlap parameter + ! + call get_alpha_exp(nCol, nLev, deltaZb, de_lgth, cloud_overlap_param) + + ! For exponential random overlap... + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == iovr_exprand) then + do iLay = 1, nLev + do iCol = 1, nCol + if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then + cloud_overlap_param(iCol,iLay) = 0._kind_phys + endif + enddo + enddo + endif + + ! + ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) + ! + precip_overlap_param = cloud_overlap_param + + end subroutine GFS_rrtmgp_thompsonmp_pre_run + + ! ######################################################################################### + ! ######################################################################################### + subroutine GFS_rrtmgp_thompsonmp_pre_finalize() + end subroutine GFS_rrtmgp_thompsonmp_pre_finalize +end module GFS_rrtmgp_thompsonmp_pre \ No newline at end of file diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta new file mode 100644 index 000000000..a2bc0af2b --- /dev/null +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -0,0 +1,555 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_thompsonmp_pre + type = scheme + dependencies = rrtmgp_aux.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_rrtmgp_thompspnmp_pre_run + type = scheme +[nCol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + 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 +[nTracers] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ncnd] + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types + units = count + dimensions = () + type = integer + intent = in + optional = F +[doSWrad] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[doLWrad] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[effr_in] + standard_name = flag_for_cloud_effective_radii + long_name = flag for cloud effective radii calculations in GFDL microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[uni_cld] + standard_name = flag_for_uni_cld + long_name = flag for uni_cld + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lmfshal] + standard_name = flag_for_lmfshal + long_name = flag for lmfshal + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lmfdeep2] + standard_name = flag_for_scale_aware_mass_flux_convection + long_name = flag for some scale-aware mass-flux convection scheme active + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[i_cldliq] + 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 +[i_cldice] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[i_cldrain] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[i_cldsnow] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[i_cldgrpl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[i_cldtot] + standard_name = index_for_cloud_amount + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in + optional = F +[i_cldliq_nc] + 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 +[i_cldice_nc] + 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 +[i_twa] + standard_name = index_for_water_friendly_aerosols + long_name = tracer index for water friendly aerosol + units = index + dimensions = () + type = integer + intent = in + optional = F +[effrin_cldliq] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[effrin_cldice] + standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[effrin_cldsnow] + standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um + long_name = effective radius of cloud snow particle in micrometers + units = um + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cld_frac_mg] + standard_name = cloud_fraction_for_MG + long_name = cloud fraction used by Morrison-Gettelman MP + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = in + optional = F +[iovr] + standard_name = flag_for_cloud_overlap_method + long_name = flag for cloud overlap method used by radiation scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_dimension) + type = real + intent = in + kind = kind_phys + optional = F +[idcor] + standard_name = flag_for_decorrelation_length_method + long_name = flag for decorrelation length method used in cloud overlap method (iovr) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dcorr_con] + standard_name = decorreltion_length_used_by_overlap_method + long_name = decorrelation length (default) used by cloud overlap method (iovr) + units = km + dimensions = () + type = real + intent = in + kind = kind_phys + optional = F +[idcor_con] + standard_name = flag_for_constant_decorrelation_length_method + long_name = choice of decorrelation length computation (costant) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor_hogan] + standard_name = flag_for_hogan_decorrelation_length_method + long_name = choice of decorrelation length computation (hogan) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor_oreopoulos] + standard_name = flag_for_oreopoulos_decorrelation_length_method + long_name = choice of decorrelation length computation (oreopoulos) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa + long_name = air pressure at vertical interface for radiation calculation + units = hPa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa + long_name = air pressure at vertical layer for radiation calculation + units = hPa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tv_lay] + standard_name = virtual_temperature + long_name = layer virtual temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qs_lay] + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q_lay] + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio + units = kg/kg + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[relhum] + standard_name = relative_humidity + long_name = layer relative humidity + units = frac + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tracer] + standard_name = chemical_tracers + long_name = chemical tracers + units = g g-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers) + 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_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + 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_epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[de_lgth] + standard_name = cloud_decorrelation_length + long_name = cloud decorrelation length + units = km + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = micron + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = micron + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = micron + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = micron + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[precip_overlap_param] + standard_name = precip_overlap_param + long_name = precipitation overlap parameter + units = km + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[deltaZb] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_dimension,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 + 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 \ No newline at end of file diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index ebc5ea2ae..592b88e32 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -293,55 +293,6 @@ subroutine sgscloud_radpre_run( & endif ! timestep > 1 -!> - Compute SFC/low/middle/high cloud top pressure for each cloud domain for given latitude. - - do i =1, im - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - do i =1, im - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - - cldcnv = 0. - -! DH* 20200723 -! iovr == 4 or 5 requires alpha, which is computed in GFS_rrmtg_pre, -! which comes after SGSCloud_RadPre. Computing alpha here requires -! a lot more input variables and computations (dzlay etc.), and -! recomputing it in GFS_rrmtg_pre is a waste of time. Workaround: -! pass a dummy array initialized to zero to gethml for other values of iovr. - if ( iovr == 4 .or. iovr == 5 ) then - errmsg = 'Logic error in sgscloud_radpre: iovr==4 or 5 not implemented' - errflg = 1 - return - end if -!! Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options -! if ( iovr == 4 .or. iovr == 5 ) then -! call get_alpha_exp & -!! --- inputs: -! (im, nlay, dzlay, iovr, latdeg, julian, yearlen, clouds1, & -!! --- outputs: -! alpha & -! ) -! endif - alpha_dummy = 0.0 -! *DH 2020723 - -!> - Recompute the diagnostic high, mid, low, total and bl cloud fraction - call gethml & -! --- inputs: - ( plyr, ptop1, clouds1, cldcnv, dz, de_lgth, alpha_dummy, & -! --- outputs: - im, nlay, cldsa, mtopa, mbota) - - !print*,"===Finished adding subgrid clouds to the resolved-scale clouds" - !print*,"qc_save:",qc_save(1,1)," qi_save:",qi_save(1,1) - end subroutine sgscloud_radpre_run end module sgscloud_radpre From 50c6e6f9a1bbe93b3f1b997401e58848e76c73fb Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Nov 2020 16:00:50 -0700 Subject: [PATCH 02/67] ThompsonMP w/ RRTMGP working --- physics/GFS_rrtmgp_gfdlmp_pre.meta | 2 +- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 136 +++++++++++++++---------- physics/GFS_rrtmgp_thompsonmp_pre.meta | 48 ++++++--- 3 files changed, 117 insertions(+), 69 deletions(-) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 3841afc9b..90f4d5daf 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_gfdlmp_pre type = scheme - dependencies = rrtmgp_aux.F90 + dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index f815ba0cc..646e45c31 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -17,6 +17,7 @@ module GFS_rrtmgp_thompsonmp_pre make_IceNumber, & make_DropletNumber, & make_RainNumber + implicit none ! Parameters specific to THOMPSONMP scheme. real(kind_phys), parameter :: & @@ -44,6 +45,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i lat, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, & qs_lay, q_lay, relhum, cld_frac_mg, con_pi, con_g, con_rd, con_epsq, iovr, iovr_dcorr, uni_cld, lmfshal, lmfdeep2, ltaerosol, & iovr_exp,iovr_exprand, idcor, dcorr_con, idcor_con, idcor_hogan, idcor_oreopoulos, & + do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cloud_overlap_param, precip_overlap_param, de_lgth, & deltaZb, errmsg, errflg) @@ -72,7 +74,9 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i idcor, & ! Choice of method for decorrelation length computation idcor_con, & ! Flag for decorrelation-length. Use constant value idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) - idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + idcor_oreopoulos, & ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + imfdeepcnv, & ! Choice of mass-flux deep convection scheme + imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad, & ! Call LW radiation @@ -80,7 +84,8 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i uni_cld, & ! lmfshal, & ! lmfdeep2, & ! - ltaerosol ! + ltaerosol, & ! + do_mynnedmf ! Flag to activate MYNN-EDMF real(kind_phys), intent(in) :: & julian, & ! Julian day con_pi, & ! Physical constant: pi @@ -104,7 +109,12 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i tracer ! Cloud condensate amount in layer by type () ! In/Outs - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & + real(kind_phys), dimension(nCol,nLev), intent(inout) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for ice cloud-particles (microns) effrin_cldsnow ! Effective radius for snow cloud-particles (microns) @@ -113,11 +123,6 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i real(kind_phys), dimension(nCol),intent(out) :: & de_lgth ! Decorrelation length real(kind_phys), dimension(nCol,nLev),intent(out) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius cld_swp, & ! Cloud snow water path cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path @@ -132,7 +137,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i errflg ! Error flag ! Local variables - real(kind_phys) :: tem0, tem1, tem2, pfac, clwt, clwm, onemrh, xrc3 + real(kind_phys) :: tem0, tem1, tem2, pfac, clwt, clwm, onemrh, clwmin, clwf real(kind_phys), dimension(nLev+1) :: hgtb real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate @@ -156,16 +161,6 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i iSFC = 1 iTOA = nLev endif - - ! Initialize outputs - cld_lwp(:,:) = 0.0 - cld_reliq(:,:) = 0.0 - cld_iwp(:,:) = 0.0 - cld_reice(:,:) = 0.0 - cld_rwp(:,:) = 0.0 - cld_rerain(:,:) = 0.0 - cld_swp(:,:) = 0.0 - cld_resnow(:,:) = 0.0 ! #################################################################################### ! Pull out cloud information for THOMPSON MP scheme. @@ -177,11 +172,20 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel tracer(1:nCol,1:nLev,i_cldgrpl) - - ! - ! Compute effective radii for liquid/ice/snow using subgrid scale clouds - ! - + + ! Cloud particle size + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + enddo + enddo + ! First, prepare cloud mixing-ratios and number concentrations for Calc_Re rho = p_lay(1:nCol,1:nLev)/(con_rd*t_lay(1:nCol,1:nLev)) orho = 1./rho @@ -214,6 +218,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i enddo enddo + ! Compute effective radii for liquid/ice/snow using subgrid scale clouds ! Call Thompson's subroutine to compute effective radii do iCol=1,nCol call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & @@ -225,42 +230,61 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i effrin_cldliq(1:nCol,1:nLev) = re_cloud(1:nCol,1:nLev)*1.e6 effrin_cldice(1:nCol,1:nLev) = re_ice(1:nCol,1:nLev)*1.e6 effrin_cldsnow(1:nCol,1:nLev) = re_snow(1:nCol,1:nLev)*1.e6 - - if (uni_cld) then - if (effr_in) then - cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) - cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) - cld_rerain(1:nCol,1:nLev) = rerain_def - cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) - else - cld_reliq(1:nCol,1:nLev) = reliq_def - cld_reice(1:nCol,1:nLev) = reice_def - cld_rerain(1:nCol,1:nLev) = rerain_def - cld_resnow(1:nCol,1:nLev) = resnow_def - endif ! effr_in - endif ! uni_cld + cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) + cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) + cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) + cld_rerain(1:nCol,1:nLev) = rerain_def - ! Cloud-fraction - cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) + ! Compute cloud-fraction. The logic is a mess here. I don't have any idea where these + ! magic numbers are coming from. + if(.not. do_mynnedmf .or. imfdeepcnv .ne. imfdeepcnv_gf ) then ! MYNN PBL or GF conv + ! Cloud-fraction + if (uni_cld) then + cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) + else + clwmin = 0.0 + if (.not. lmfshal) then + do iLay = 1, nLev + do iCol = 1, nCol + clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & + tracer(iCol,iLay,i_cldsnow) + clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) + if (clwf > clwt) then + onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) + clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) + tem1 = 2000.0 / min(max(sqrt(sqrt(onemrh*qs_lay(iCol,iLay))),0.0001),1.0) + tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) + ! + cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) + endif + enddo + enddo + else + do iLay = 1, nLev + do iCol = 1, nCol + clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & + tracer(iCol,iLay,i_cldsnow) + clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) + if (clwf > clwt) then + onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) + clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) + tem1 = 100.0 / min(max((onemrh*qs_lay(iCol,iLay))**0.49,0.0001),1.0) !jhan + tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) + ! + cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) + endif + enddo + enddo + endif + endif + endif + ! Precipitation fraction (Hack. For now use cloud-fraction) precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) - - ! Condensate and effective size - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay = 1, nLev - do iCol = 1, nCol - ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - if (cld_frac(iCol,iLay) .ge. cllimit) then - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) - cld_lwp(iCol,iLay) = cld_condensate(iCol,iLay,1) * tem1 - cld_iwp(iCol,iLay) = cld_condensate(iCol,iLay,2) * tem1 - cld_rwp(iCol,iLay) = cld_condensate(iCol,iLay,3) * tem1 - cld_swp(iCol,iLay) = cld_condensate(iCol,iLay,4) * tem1 - endif - enddo - enddo - + ! #################################################################################### ! Cloud (and precipitation) overlap ! #################################################################################### diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index a2bc0af2b..bcc394c82 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] name = GFS_rrtmgp_thompsonmp_pre type = scheme - dependencies = rrtmgp_aux.F90 + dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_thompspnmp_pre_run + name = GFS_rrtmgp_thompsonmp_pre_run type = scheme [nCol] standard_name = horizontal_loop_extent @@ -212,7 +212,7 @@ intent = in optional = F [iovr] - standard_name = flag_for_cloud_overlap_method + standard_name = flag_for_cloud_overlap_method_for_radiation long_name = flag for cloud overlap method used by radiation scheme units = flag dimensions = () @@ -302,6 +302,30 @@ type = integer intent = in optional = F +[do_mynnedmf] + standard_name = do_mynnedmf + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in + optional = F +[imfdeepcnv] + standard_name = flag_for_mass_flux_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imfdeepcnv_gf] + standard_name = flag_for_gf_deep_convection_scheme + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure at vertical interface for radiation calculation @@ -426,7 +450,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_lwp] standard_name = cloud_liquid_water_path @@ -435,16 +459,16 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_reliq] standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud - units = micron + units = um dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_iwp] standard_name = cloud_ice_water_path @@ -453,16 +477,16 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_reice] standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud - units = micron + units = um dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_swp] standard_name = cloud_snow_water_path @@ -476,7 +500,7 @@ [cld_resnow] standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow cloud - units = micron + units = um dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys @@ -494,7 +518,7 @@ [cld_rerain] standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain cloud - units = micron + units = um dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys From 0865ca98a4ac71c743d22e70acd7e204143adee0 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Nov 2020 16:08:58 -0700 Subject: [PATCH 03/67] Some readability changes --- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 171 +++++++++++++------------- 1 file changed, 85 insertions(+), 86 deletions(-) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index 646e45c31..c10252fee 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -4,19 +4,19 @@ ! ######################################################################################## module GFS_rrtmgp_thompsonmp_pre use machine, only: & - kind_phys + kind_phys use rrtmgp_aux, only: & - check_error_msg + check_error_msg use module_radiation_cloud_overlap, only: & - cmp_dcorr_lgth, & - get_alpha_exp + cmp_dcorr_lgth, & + get_alpha_exp use module_mp_thompson, only: & - calc_effectRad, & - Nt_c + calc_effectRad, & + Nt_c use module_mp_thompson_make_number_concentrations, only: & - make_IceNumber, & - make_DropletNumber, & - make_RainNumber + make_IceNumber, & + make_DropletNumber, & + make_RainNumber implicit none ! Parameters specific to THOMPSONMP scheme. @@ -26,30 +26,30 @@ module GFS_rrtmgp_thompsonmp_pre rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) cllimit = 0.001 ! Lowest cloud fraction in GFDL MP scheme - - public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize - + + public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize + contains ! ###################################################################################### ! ###################################################################################### subroutine GFS_rrtmgp_thompsonmp_pre_init() end subroutine GFS_rrtmgp_thompsonmp_pre_init - + ! ###################################################################################### ! ###################################################################################### !! \section arg_table_GFS_rrtmgp_thompsonmp_pre_run !! \htmlinclude GFS_rrtmgp_thompsonmp_pre_run.html !! subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice,& - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, yearlen, doSWrad, doLWrad, effr_in, julian, & - lat, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, & - qs_lay, q_lay, relhum, cld_frac_mg, con_pi, con_g, con_rd, con_epsq, iovr, iovr_dcorr, uni_cld, lmfshal, lmfdeep2, ltaerosol, & - iovr_exp,iovr_exprand, idcor, dcorr_con, idcor_con, idcor_hogan, idcor_oreopoulos, & - do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, & + yearlen, doSWrad, doLWrad, effr_in, julian, lat, p_lev, p_lay, tv_lay, t_lay, & + effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, & + cld_frac_mg, con_pi, con_g, con_rd, con_epsq, iovr, iovr_dcorr, uni_cld, lmfshal, & + lmfdeep2, ltaerosol, iovr_exp,iovr_exprand, idcor, dcorr_con, idcor_con, & + idcor_hogan, idcor_oreopoulos, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cloud_overlap_param, precip_overlap_param, de_lgth, & deltaZb, errmsg, errflg) - implicit none ! Inputs integer, intent(in) :: & @@ -107,8 +107,8 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i p_lev ! Pressure at model-level interfaces (Pa) real(kind_phys), dimension(nCol, nLev, nTracers),intent(in) :: & tracer ! Cloud condensate amount in layer by type () - - ! In/Outs + + ! In/Outs real(kind_phys), dimension(nCol,nLev), intent(inout) :: & cld_frac, & ! Total cloud fraction cld_lwp, & ! Cloud liquid water path @@ -143,15 +143,15 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate integer :: iCol,iLay,l,iSFC,iTOA real(kind_phys), dimension(nCol,nLev) :: deltaP, deltaZ, rho, orho, re_cloud, re_ice,& - re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa + re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa logical :: top_at_1 ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + if (.not. (doSWrad .or. doLWrad)) return - + ! What is vertical ordering? top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) if (top_at_1) then @@ -165,7 +165,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i ! #################################################################################### ! Pull out cloud information for THOMPSON MP scheme. ! #################################################################################### - + ! Cloud condensate cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water @@ -191,21 +191,21 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i orho = 1./rho do iLay = 1, nLev do iCol = 1, nCol - qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) - qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) - qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) - qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) - nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) - if (ltaerosol) then - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) - nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) - else - nc_mp(iCol,iLay) = nt_c*orho(iCol,iLay) - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) - endif + qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) + qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) + qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) + qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) + nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + if (ltaerosol) then + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) + else + nc_mp(iCol,iLay) = nt_c*orho(iCol,iLay) + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + endif enddo enddo - + ! Update number concentration, consistent with sub-grid clouds do iLay = 1, nLev do iCol = 1, nCol @@ -217,13 +217,13 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i endif enddo enddo - + ! Compute effective radii for liquid/ice/snow using subgrid scale clouds ! Call Thompson's subroutine to compute effective radii do iCol=1,nCol call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & - nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & - re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) + nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & + re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) enddo ! Scale Thompson's effective radii from meter to micron and update global effective radii. @@ -234,61 +234,60 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) cld_rerain(1:nCol,1:nLev) = rerain_def - - ! Compute cloud-fraction. The logic is a mess here. I don't have any idea where these - ! magic numbers are coming from. + + ! Compute cloud-fraction. The logic is a mess here. I don't have any idea where these + ! magic numbers are coming from. if(.not. do_mynnedmf .or. imfdeepcnv .ne. imfdeepcnv_gf ) then ! MYNN PBL or GF conv - ! Cloud-fraction - if (uni_cld) then + ! Cloud-fraction + if (uni_cld) then cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) else - clwmin = 0.0 - if (.not. lmfshal) then - do iLay = 1, nLev - do iCol = 1, nCol - clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & - tracer(iCol,iLay,i_cldsnow) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) - if (clwf > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) - tem1 = 2000.0 / min(max(sqrt(sqrt(onemrh*qs_lay(iCol,iLay))),0.0001),1.0) - tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - ! - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) + clwmin = 0.0 + if (.not. lmfshal) then + do iLay = 1, nLev + do iCol = 1, nCol + clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & + tracer(iCol,iLay,i_cldsnow) + clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) + if (clwf > clwt) then + onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) + clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) + tem1 = 2000.0 / min(max(sqrt(sqrt(onemrh*qs_lay(iCol,iLay))),0.0001),1.0) + tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) + ! + cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) endif - enddo - enddo - else - do iLay = 1, nLev - do iCol = 1, nCol - clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & - tracer(iCol,iLay,i_cldsnow) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) - - if (clwf > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) - tem1 = 100.0 / min(max((onemrh*qs_lay(iCol,iLay))**0.49,0.0001),1.0) !jhan - tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - ! - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) - endif - enddo + enddo enddo - endif - endif - endif - + else + do iLay = 1, nLev + do iCol = 1, nCol + clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & + tracer(iCol,iLay,i_cldsnow) + clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) + if (clwf > clwt) then + onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) + clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) + tem1 = 100.0 / min(max((onemrh*qs_lay(iCol,iLay))**0.49,0.0001),1.0) !jhan + tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) + ! + cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) + endif + enddo + enddo + endif + endif + endif + ! Precipitation fraction (Hack. For now use cloud-fraction) precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) ! #################################################################################### ! Cloud (and precipitation) overlap ! #################################################################################### - + ! ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) ! @@ -379,4 +378,4 @@ end subroutine GFS_rrtmgp_thompsonmp_pre_run ! ######################################################################################### subroutine GFS_rrtmgp_thompsonmp_pre_finalize() end subroutine GFS_rrtmgp_thompsonmp_pre_finalize -end module GFS_rrtmgp_thompsonmp_pre \ No newline at end of file +end module GFS_rrtmgp_thompsonmp_pre From c30535ff5fc1050b40f0e9d0536af08850e55087 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 10 Nov 2020 15:35:31 -0700 Subject: [PATCH 04/67] Further refinements to ThompsonMP - RRTMGP coupling --- physics/GFS_rrtmgp_cloud_overlap_pre.F90 | 192 ++++++++++++++++ physics/GFS_rrtmgp_cloud_overlap_pre.meta | 265 ++++++++++++++++++++++ physics/GFS_rrtmgp_thompsonmp_pre.F90 | 257 ++++++--------------- physics/GFS_rrtmgp_thompsonmp_pre.meta | 159 +------------ 4 files changed, 532 insertions(+), 341 deletions(-) create mode 100644 physics/GFS_rrtmgp_cloud_overlap_pre.F90 create mode 100644 physics/GFS_rrtmgp_cloud_overlap_pre.meta diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 new file mode 100644 index 000000000..08bc82d05 --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 @@ -0,0 +1,192 @@ +! ######################################################################################## +! +! ######################################################################################## +module GFS_rrtmgp_cloud_overlap_pre + use machine, only: kind_phys + use rrtmgp_aux, only: check_error_msg + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + + public GFS_rrtmgp_cloud_overlap_pre_init, GFS_rrtmgp_cloud_overlap_pre_run, GFS_rrtmgp_cloud_overlap_pre_finalize + +contains + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_cloud_overlap_pre_init() + end subroutine GFS_rrtmgp_cloud_overlap_pre_init + + ! ###################################################################################### + ! ###################################################################################### +!! \section arg_table_GFS_rrtmgp_cloud_overlap_pre_run +!! \htmlinclude GFS_rrtmgp_cloud_overlap_pre_run.html +!! + subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWrad, & + julian, lat, p_lev, p_lay, tv_lay, con_pi, con_g, con_rd, con_epsq, dcorr_con, & + idcor, iovr, iovr_dcorr, iovr_exprand, iovr_exp, idcor_con, idcor_hogan, & + idcor_oreopoulos, cld_frac, & + cloud_overlap_param, precip_overlap_param, de_lgth, deltaZc, errmsg, errflg) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + yearlen, & ! Length of current year (365/366) WTF? + iovr, & ! Choice of cloud-overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + idcor, & ! Choice of method for decorrelation length computation + idcor_con, & ! Flag for decorrelation-length. Use constant value + idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) + idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + logical, intent(in) :: & + doSWrad, & ! Call SW radiation? + doLWrad ! Call LW radiation + real(kind_phys), intent(in) :: & + julian, & ! Julian day + con_pi, & ! Physical constant: pi + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_epsq, & ! Physical constant: Minimum value for specific humidity + dcorr_con ! Decorrelation-length (used if idcor = idcor_con) + real(kind_phys), dimension(nCol), intent(in) :: & + lat ! Latitude + real(kind_phys), dimension(nCol,nLev), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + p_lay, & ! Pressure at model-layers (Pa) + cld_frac ! Total cloud fraction + real(kind_phys), dimension(nCol,nLev+1), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + + ! Outputs + real(kind_phys), dimension(nCol),intent(out) :: & + de_lgth ! Decorrelation length + real(kind_phys), dimension(nCol,nLev),intent(out) :: & + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param, & ! Precipitation overlap parameter + deltaZc ! Layer thickness (from layer-centers)(km) + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local variables + real(kind_phys) :: tem1,pfac + real(kind_phys), dimension(nLev+1) :: hgtb + real(kind_phys), dimension(nLev) :: hgtc + integer :: iCol,iLay,l,iSFC,iTOA + real(kind_phys), dimension(nCol,nLev) :: deltaZ + logical :: top_at_1 + + if (.not. (doSWrad .or. doLWrad)) return + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! What is vertical ordering? + top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) + if (top_at_1) then + iSFC = nLev + iTOA = 1 + else + iSFC = 1 + iTOA = nLev + endif + + ! + ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) + ! + do iCol=1,nCol + if (top_at_1) then + ! Layer thickness (km) + do iLay=1,nLev + deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(nLev+1) = 0._kind_phys + do iLay=nLev,1,-1 + hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = nLev, 1, -1 + pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & + abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) + hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) + enddo + ! Layer thickness between centers + do iLay = nLev-1, 1, -1 + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) + enddo + deltaZc(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) + else + do iLay=nLev,1,-1 + deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(1) = 0._kind_phys + do iLay=1,nLev + hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = 1, nLev + pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & + abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) + hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) + enddo + ! Layer thickness between centers + do iLay = 2, nLev + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) + enddo + deltaZc(iCol,1) = hgtc(1) - hgtb(1) + endif + enddo + + ! + ! Cloud decorrelation length + ! + if (idcor == idcor_hogan) then + call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) + endif + if (idcor == idcor_oreopoulos) then + call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) + endif + if (idcor == idcor_con) then + de_lgth(:) = dcorr_con + endif + + ! + ! Cloud overlap parameter + ! + if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then + call get_alpha_exp(nCol, nLev, deltaZc, de_lgth, cloud_overlap_param) + else + de_lgth(:) = 0. + cloud_overlap_param(:,:) = 0. + endif + + ! For exponential random overlap... + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == iovr_exprand) then + do iLay = 1, nLev + do iCol = 1, nCol + if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then + cloud_overlap_param(iCol,iLay) = 0._kind_phys + endif + enddo + enddo + endif + + ! + ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) + ! + precip_overlap_param = cloud_overlap_param + + end subroutine GFS_rrtmgp_cloud_overlap_pre_run + + ! ######################################################################################### + ! ######################################################################################### + subroutine GFS_rrtmgp_cloud_overlap_pre_finalize() + end subroutine GFS_rrtmgp_cloud_overlap_pre_finalize +end module GFS_rrtmgp_cloud_overlap_pre diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.meta b/physics/GFS_rrtmgp_cloud_overlap_pre.meta new file mode 100644 index 000000000..273832362 --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.meta @@ -0,0 +1,265 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_cloud_overlap_pre + type = scheme + dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_rrtmgp_cloud_overlap_pre_run + type = scheme +[nCol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + 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 +[doSWrad] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[doLWrad] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa + long_name = air pressure at vertical interface for radiation calculation + units = hPa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa + long_name = air pressure at vertical layer for radiation calculation + units = hPa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tv_lay] + standard_name = virtual_temperature + long_name = layer virtual temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + 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_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + 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_epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = flag for cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor] + standard_name = flag_for_decorrelation_length_method + long_name = flag for decorrelation length method used in cloud overlap method (iovr) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor_con] + standard_name = flag_for_constant_decorrelation_length_method + long_name = choice of decorrelation length computation (costant) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor_hogan] + standard_name = flag_for_hogan_decorrelation_length_method + long_name = choice of decorrelation length computation (hogan) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[idcor_oreopoulos] + standard_name = flag_for_oreopoulos_decorrelation_length_method + long_name = choice of decorrelation length computation (oreopoulos) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dcorr_con] + standard_name = decorreltion_length_used_by_overlap_method + long_name = decorrelation length (default) used by cloud overlap method (iovr) + units = km + dimensions = () + type = real + intent = in + kind = kind_phys + optional = F +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[de_lgth] + standard_name = cloud_decorrelation_length + long_name = cloud decorrelation length + units = km + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[precip_overlap_param] + standard_name = precip_overlap_param + long_name = precipitation overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[deltaZc] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,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 + 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/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index c10252fee..758e810fb 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -7,9 +7,6 @@ module GFS_rrtmgp_thompsonmp_pre kind_phys use rrtmgp_aux, only: & check_error_msg - use module_radiation_cloud_overlap, only: & - cmp_dcorr_lgth, & - get_alpha_exp use module_mp_thompson, only: & calc_effectRad, & Nt_c @@ -40,16 +37,14 @@ end subroutine GFS_rrtmgp_thompsonmp_pre_init !! \section arg_table_GFS_rrtmgp_thompsonmp_pre_run !! \htmlinclude GFS_rrtmgp_thompsonmp_pre_run.html !! - subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice,& - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, & - yearlen, doSWrad, doLWrad, effr_in, julian, lat, p_lev, p_lay, tv_lay, t_lay, & - effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, & - cld_frac_mg, con_pi, con_g, con_rd, con_epsq, iovr, iovr_dcorr, uni_cld, lmfshal, & - lmfdeep2, ltaerosol, iovr_exp,iovr_exprand, idcor, dcorr_con, idcor_con, & - idcor_hogan, idcor_oreopoulos, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, cloud_overlap_param, precip_overlap_param, de_lgth, & - deltaZb, errmsg, errflg) + subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, doLWrad, & + i_cldliq, i_cldice, i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, & + i_cldice_nc, i_twa, effr_in, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, & + effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, cld_frac_mg, con_g, & + con_rd, uni_cld, lmfshal, lmfdeep2, ltaerosol, do_mynnedmf, imfdeepcnv, & + imfdeepcnv_gf, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -66,15 +61,6 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i i_cldliq_nc, & ! cloud liquid number concentration. i_cldice_nc, & ! cloud ice number concentration. i_twa, & ! water friendly aerosol. - yearlen, & ! Length of current year (365/366) WTF? - iovr, & ! Choice of cloud-overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - idcor, & ! Choice of method for decorrelation length computation - idcor_con, & ! Flag for decorrelation-length. Use constant value - idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) - idcor_oreopoulos, & ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) imfdeepcnv, & ! Choice of mass-flux deep convection scheme imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme logical, intent(in) :: & @@ -87,14 +73,9 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i ltaerosol, & ! do_mynnedmf ! Flag to activate MYNN-EDMF real(kind_phys), intent(in) :: & - julian, & ! Julian day - con_pi, & ! Physical constant: pi con_g, & ! Physical constant: gravitational constant - con_rd, & ! Physical constant: gas-constant for dry air - con_epsq, & ! Physical constant(?): Minimum value for specific humidity - dcorr_con ! Decorrelation-length (used if idcor = 0, default is idcor = 1) - real(kind_phys), dimension(nCol), intent(in) :: & - lat ! Latitude (radians) + con_rd ! Physical constant: gas-constant for dry air + real(kind_phys), dimension(nCol,nLev), intent(in) :: & tv_lay, & ! Virtual temperature (K) t_lay, & ! Temperature (K) @@ -120,28 +101,21 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i effrin_cldsnow ! Effective radius for snow cloud-particles (microns) ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & - de_lgth ! Decorrelation length real(kind_phys), dimension(nCol,nLev),intent(out) :: & - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param, & ! Precipitation overlap parameter - deltaZb ! Layer thickness (km) + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac ! Precipitation fraction character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & errflg ! Error flag ! Local variables - real(kind_phys) :: tem0, tem1, tem2, pfac, clwt, clwm, onemrh, clwmin, clwf - real(kind_phys), dimension(nLev+1) :: hgtb - real(kind_phys), dimension(nLev) :: hgtc + real(kind_phys) :: alpha0, pfac, tem1, cld_mr real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - integer :: iCol,iLay,l,iSFC,iTOA + integer :: iCol,iLay,l real(kind_phys), dimension(nCol,nLev) :: deltaP, deltaZ, rho, orho, re_cloud, re_ice,& re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa logical :: top_at_1 @@ -151,21 +125,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i errflg = 0 if (.not. (doSWrad .or. doLWrad)) return - - ! What is vertical ordering? - top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) - if (top_at_1) then - iSFC = nLev - iTOA = 1 - else - iSFC = 1 - iTOA = nLev - endif - - ! #################################################################################### - ! Pull out cloud information for THOMPSON MP scheme. - ! #################################################################################### - + ! Cloud condensate cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water @@ -235,147 +195,74 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) cld_rerain(1:nCol,1:nLev) = rerain_def - ! Compute cloud-fraction. The logic is a mess here. I don't have any idea where these - ! magic numbers are coming from. + ! Compute cloud-fraction. Else, use value provided if(.not. do_mynnedmf .or. imfdeepcnv .ne. imfdeepcnv_gf ) then ! MYNN PBL or GF conv ! Cloud-fraction if (uni_cld) then cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) else - clwmin = 0.0 - if (.not. lmfshal) then - do iLay = 1, nLev - do iCol = 1, nCol - clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & - tracer(iCol,iLay,i_cldsnow) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) - if (clwf > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) - tem1 = 2000.0 / min(max(sqrt(sqrt(onemrh*qs_lay(iCol,iLay))),0.0001),1.0) - tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - ! - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) - endif - enddo - enddo - else - do iLay = 1, nLev - do iCol = 1, nCol - clwf = tracer(iCol,iLay,i_cldliq) + tracer(iCol,iLay,i_cldice) + & - tracer(iCol,iLay,i_cldsnow) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.001) - if (clwf > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.001 ) - tem1 = 100.0 / min(max((onemrh*qs_lay(iCol,iLay))**0.49,0.0001),1.0) !jhan - tem1 = max( min( tem1*(clwf-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - ! - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-tem1)), 0.0 ) - endif - enddo + if( lmfshal) alpha0 = 100. ! Default + if(.not. lmfshal) alpha0 = 2000. + ! Xu-Randall (1996) cloud-fraction + do iLay = 1, nLev + do iCol = 1, nCol + cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & + cld_condensate(iCol,iLay,4) + cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) enddo - endif + enddo endif endif ! Precipitation fraction (Hack. For now use cloud-fraction) precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) - ! #################################################################################### - ! Cloud (and precipitation) overlap - ! #################################################################################### - - ! - ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) - ! - do iCol=1,nCol - if (top_at_1) then - ! Layer thickness (km) - do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(nLev+1) = 0._kind_phys - do iLay=nLev,1,-1 - hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = nLev, 1, -1 - pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & - abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) - hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) - enddo - ! Layer thickness between centers - do iLay = nLev-1, 1, -1 - deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) - enddo - deltaZb(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) - else - do iLay=nLev,1,-1 - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(1) = 0._kind_phys - do iLay=1,nLev - hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = 1, nLev - pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & - abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) - hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) - enddo - ! Layer thickness between centers - do iLay = 2, nLev - deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) - enddo - deltaZb(iCol,1) = hgtc(1) - hgtb(1) - endif - enddo - - ! - ! Cloud decorrelation length - ! - if (idcor == idcor_hogan) then - call cmp_dcorr_lgth(nCol, abs(lat/con_pi), con_pi, de_lgth) - endif - if (idcor == idcor_oreopoulos) then - call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) - endif - if (idcor == idcor_con) then - de_lgth(:) = dcorr_con - endif - - ! - ! Cloud overlap parameter - ! - call get_alpha_exp(nCol, nLev, deltaZb, de_lgth, cloud_overlap_param) - - ! For exponential random overlap... - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then - cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif - - ! - ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) - ! - precip_overlap_param = cloud_overlap_param - end subroutine GFS_rrtmgp_thompsonmp_pre_run - ! ######################################################################################### - ! ######################################################################################### + ! ###################################################################################### + ! ###################################################################################### subroutine GFS_rrtmgp_thompsonmp_pre_finalize() end subroutine GFS_rrtmgp_thompsonmp_pre_finalize + + ! ###################################################################################### + ! This function computes the cloud-fraction following. + ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models + ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 + ! + ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P + ! + ! ###################################################################################### + function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) + + ! Inputs + real(kind_phys), intent(in) :: & + p_lay, & ! Pressure (Pa) + qs_lay, & ! Saturation vapor-pressure (Pa) + relhum, & ! Relative humidity + cld_mr, & ! Total cloud mixing ratio + alpha ! Scheme parameter (default=100) + ! Outputs + real(kind_phys) :: cld_frac_XuRandall + ! Locals + real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 + ! Parameters + real(kind_phys) :: & + lambda = 0.50, & ! + P = 0.25 + + clwt = 1.0e-6 * (p_lay*0.001) + if (cld_mr > clwt) then + onemrh = max(1.e-10, 1.0 - relhum) + tem1 = alpha / min(max((onemrh*qs_lay)**lambda,0.0001),1.0) + tem2 = max(min(tem1*(cld_mr - clwt), 50.0 ), 0.0 ) + tem3 = sqrt(sqrt(relhum)) ! This assumes "p" = 0.25. Identical, but cheaper than relhum**p + ! + cld_frac_XuRandall = max( tem3*(1.0-exp(-tem2)), 0.0 ) + else + cld_frac_XuRandall = 0.0 + endif + + return + end function end module GFS_rrtmgp_thompsonmp_pre diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index bcc394c82..b00e27fd8 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_thompsonmp_pre type = scheme - dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90 + dependencies = rrtmgp_aux.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] @@ -203,105 +203,6 @@ kind = kind_phys intent = in optional = F -[yearlen] - standard_name = number_of_days_in_year - long_name = number of days in a year - units = days - dimensions = () - type = integer - intent = in - optional = F -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = flag for cloud overlap method used by radiation scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[julian] - standard_name = julian_day - long_name = julian day - units = days - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_dimension) - type = real - intent = in - kind = kind_phys - optional = F -[idcor] - standard_name = flag_for_decorrelation_length_method - long_name = flag for decorrelation length method used in cloud overlap method (iovr) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[dcorr_con] - standard_name = decorreltion_length_used_by_overlap_method - long_name = decorrelation length (default) used by cloud overlap method (iovr) - units = km - dimensions = () - type = real - intent = in - kind = kind_phys - optional = F -[idcor_con] - standard_name = flag_for_constant_decorrelation_length_method - long_name = choice of decorrelation length computation (costant) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor_hogan] - standard_name = flag_for_hogan_decorrelation_length_method - long_name = choice of decorrelation length computation (hogan) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor_oreopoulos] - standard_name = flag_for_oreopoulos_decorrelation_length_method - long_name = choice of decorrelation length computation (oreopoulos) - units = flag - dimensions = () - type = integer - intent = in - optional = F [do_mynnedmf] standard_name = do_mynnedmf long_name = flag to activate MYNN-EDMF @@ -398,15 +299,6 @@ 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_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -424,25 +316,7 @@ type = real kind = kind_phys intent = in - optional = F -[con_epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[de_lgth] - standard_name = cloud_decorrelation_length - long_name = cloud decorrelation length - units = km - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F + optional = F [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -532,34 +406,7 @@ type = real kind = kind_phys intent = out - optional = F -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[deltaZb] - standard_name = layer_thickness - long_name = layer_thickness - units = m - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 254382d85426c65a5c1b3193ad50fd4255d2267c Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 12 Nov 2020 13:27:45 -0700 Subject: [PATCH 05/67] Cleanup of GP-ThMP interface. New scheme file for cloud-overlap pre. --- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 192 ++++---------------------- physics/GFS_rrtmgp_gfdlmp_pre.meta | 155 +-------------------- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 36 ++--- 3 files changed, 45 insertions(+), 338 deletions(-) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index 52e1a7b74..31c67d62f 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -14,8 +14,7 @@ module GFS_rrtmgp_gfdlmp_pre rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) reice_min = 10.0, & ! Minimum ice size allowed by scheme - reice_max = 150.0, & ! Maximum ice size allowed by scheme - cllimit = 0.001 ! Lowest cloud fraction in GFDL MP scheme + reice_max = 150.0 ! Maximum ice size allowed by scheme public GFS_rrtmgp_gfdlmp_pre_init, GFS_rrtmgp_gfdlmp_pre_run, GFS_rrtmgp_gfdlmp_pre_finalize @@ -31,13 +30,11 @@ end subroutine GFS_rrtmgp_gfdlmp_pre_init !! \htmlinclude GFS_rrtmgp_gfdlmp_pre_run.html !! subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, yearlen, doSWrad, doLWrad, effr_in, & - julian, lat, p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & - effrin_cldsnow, tracer, con_pi, con_g, con_rd, con_epsq, dcorr_con, idcor, iovr, & - iovr_dcorr, iovr_exprand, iovr_exp, idcor_con, idcor_hogan, idcor_oreopoulos, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, doSWrad, doLWrad, effr_in, & + p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & + effrin_cldsnow, tracer, con_g, con_rd, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, cloud_overlap_param, precip_overlap_param, de_lgth, & - deltaZb, errmsg, errflg) + cld_rerain, precip_frac, errmsg, errflg) implicit none ! Inputs @@ -51,29 +48,14 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld i_cldrain, & ! Index into tracer array for cloud rain. i_cldsnow, & ! Index into tracer array for cloud snow. i_cldgrpl, & ! Index into tracer array for cloud groupel. - i_cldtot, & ! Index into tracer array for cloud total amount. - yearlen, & ! Length of current year (365/366) WTF? - iovr, & ! Choice of cloud-overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - idcor, & ! Choice of method for decorrelation length computation - idcor_con, & ! Flag for decorrelation-length. Use constant value - idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) - idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + i_cldtot ! Index into tracer array for cloud total amount. logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad, & ! Call LW radiation effr_in ! Provide hydrometeor radii from macrophysics? real(kind_phys), intent(in) :: & - julian, & ! Julian day - con_pi, & ! Physical constant: pi con_g, & ! Physical constant: gravitational constant - con_rd, & ! Physical constant: gas-constant for dry air - con_epsq, & ! Physical constant(?): Minimum value for specific humidity - dcorr_con ! Decorrelation-length (used if idcor = idcor_con) - real(kind_phys), dimension(nCol), intent(in) :: & - lat ! Latitude + con_rd ! Physical constant: gas-constant for dry air real(kind_phys), dimension(nCol,nLev), intent(in) :: & tv_lay, & ! Virtual temperature (K) p_lay, & ! Pressure at model-layers (Pa) @@ -87,8 +69,6 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld tracer ! Cloud condensate amount in layer by type () ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & - de_lgth ! Decorrelation length real(kind_phys), dimension(nCol,nLev),intent(out) :: & cld_frac, & ! Total cloud fraction cld_lwp, & ! Cloud liquid water path @@ -99,10 +79,7 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param, & ! Precipitation overlap parameter - deltaZb ! Layer thickness (km) + precip_frac ! Precipitation fraction character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & @@ -110,10 +87,8 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld ! Local variables real(kind_phys) :: tem1,pfac - real(kind_phys), dimension(nLev+1) :: hgtb - real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - integer :: iCol,iLay,l,ncndl,iSFC,iTOA + integer :: iCol,iLay,l,ncndl real(kind_phys), dimension(nCol,nLev) :: deltaP,deltaZ logical :: top_at_1 @@ -131,16 +106,6 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld return endif - ! What is vertical ordering? - top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) - if (top_at_1) then - iSFC = nLev - iTOA = 1 - else - iSFC = 1 - iTOA = nLev - endif - ! Initialize outputs cld_lwp(:,:) = 0.0 cld_reliq(:,:) = reliq_def @@ -161,143 +126,38 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel tracer(1:nCol,1:nLev,i_cldgrpl) - ! Since we combine the snow and grapuel, define local variable for number of condensate types. - ncndl = min(4,ncnd) - - ! Set really tiny suspended particle amounts to clear - do l=1,ncndl - do iLay=1,nLev - do iCol=1,nCol - if (cld_condensate(iCol,iLay,l) < con_epsq) cld_condensate(iCol,iLay,l) = 0.0 - enddo - enddo - enddo - - ! Cloud-fraction - cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) - - ! Precipitation fraction (Hack. For now use cloud-fraction) - precip_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) - - ! Condensate and effective size + ! Cloud water path (g/m2) deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. do iLay = 1, nLev do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - if (cld_frac(iCol,iLay) .ge. cllimit) then - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) - cld_lwp(iCol,iLay) = cld_condensate(iCol,iLay,1) * tem1 - cld_iwp(iCol,iLay) = cld_condensate(iCol,iLay,2) * tem1 - cld_rwp(iCol,iLay) = cld_condensate(iCol,iLay,3) * tem1 - cld_swp(iCol,iLay) = cld_condensate(iCol,iLay,4) * tem1 - endif + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + enddo + enddo + + ! Particle size + do iLay = 1, nLev + do iCol = 1, nCol ! Use radii provided from the macrophysics if (effr_in) then cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) cld_rerain(iCol,iLay) = effrin_cldrain(iCol,iLay) cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) - else - cld_reliq(iCol,iLay) = reliq_def - cld_reice(iCol,iLay) = reice_def - cld_rerain(iCol,iLay) = rerain_def - cld_resnow(iCol,iLay) = resnow_def endif enddo enddo - ! #################################################################################### - ! Cloud (and precipitation) overlap - ! #################################################################################### - ! - ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) - ! - do iCol=1,nCol - if (top_at_1) then - ! Layer thickness (km) - do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(nLev+1) = 0._kind_phys - do iLay=nLev,1,-1 - hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = nLev, 1, -1 - pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & - abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) - hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) - enddo - ! Layer thickness between centers - do iLay = nLev-1, 1, -1 - deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) - enddo - deltaZb(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) - else - do iLay=nLev,1,-1 - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(1) = 0._kind_phys - do iLay=1,nLev - hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = 1, nLev - pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & - abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) - hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) - enddo - ! Layer thickness between centers - do iLay = 2, nLev - deltaZb(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) - enddo - deltaZb(iCol,1) = hgtc(1) - hgtb(1) - endif - enddo - - ! - ! Cloud decorrelation length - ! - if (idcor == idcor_hogan) then - call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) - endif - if (idcor == idcor_oreopoulos) then - call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) - endif - if (idcor == idcor_con) then - de_lgth(:) = dcorr_con - endif - - ! - ! Cloud overlap parameter - ! - if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exp(nCol, nLev, deltaZb, de_lgth, cloud_overlap_param) - else - de_lgth(:) = 0. - cloud_overlap_param(:,:) = 0. - endif - - ! For exponential random overlap... - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then - cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif - - ! - ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) - ! - precip_overlap_param = cloud_overlap_param + ! Cloud-fraction + cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + ! Precipitation fraction (Hack. For now use cloud-fraction) + precip_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + end subroutine GFS_rrtmgp_gfdlmp_pre_run ! ######################################################################################### diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 90f4d5daf..5894d9f5d 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -146,32 +146,6 @@ type = real kind = kind_phys intent = in - optional = F -[yearlen] - standard_name = number_of_days_in_year - long_name = number of days in a year - units = days - dimensions = () - type = integer - intent = in - optional = F -[julian] - standard_name = julian_day - long_name = julian day - units = days - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - intent = in - kind = kind_phys optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa @@ -209,15 +183,6 @@ 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_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -236,97 +201,6 @@ kind = kind_phys intent = in optional = F -[con_epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = flag for cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor] - standard_name = flag_for_decorrelation_length_method - long_name = flag for decorrelation length method used in cloud overlap method (iovr) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor_con] - standard_name = flag_for_constant_decorrelation_length_method - long_name = choice of decorrelation length computation (costant) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor_hogan] - standard_name = flag_for_hogan_decorrelation_length_method - long_name = choice of decorrelation length computation (hogan) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[idcor_oreopoulos] - standard_name = flag_for_oreopoulos_decorrelation_length_method - long_name = choice of decorrelation length computation (oreopoulos) - units = flag - dimensions = () - type = integer - intent = in - optional = F -[dcorr_con] - standard_name = decorreltion_length_used_by_overlap_method - long_name = decorrelation length (default) used by cloud overlap method (iovr) - units = km - dimensions = () - type = real - intent = in - kind = kind_phys - optional = F -[de_lgth] - standard_name = cloud_decorrelation_length - long_name = cloud decorrelation length - units = km - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -416,34 +290,7 @@ type = real kind = kind_phys intent = out - optional = F -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[deltaZb] - standard_name = layer_thickness - long_name = layer_thickness - units = m - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index 758e810fb..8b63090c0 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -16,13 +16,9 @@ module GFS_rrtmgp_thompsonmp_pre make_RainNumber implicit none - ! Parameters specific to THOMPSONMP scheme. + ! Parameters specific to THOMPSON MP scheme. real(kind_phys), parameter :: & - reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) - reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) - rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) - resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) - cllimit = 0.001 ! Lowest cloud fraction in GFDL MP scheme + rerain_def = 1000.0 ! Default rain radius to 1000 microns public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize @@ -67,10 +63,10 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do doSWrad, & ! Call SW radiation? doLWrad, & ! Call LW radiation effr_in, & ! Use cloud effective radii provided by model? - uni_cld, & ! - lmfshal, & ! - lmfdeep2, & ! - ltaerosol, & ! + uni_cld, & ! Use provided cloud-fraction? + lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall + lmfdeep2, & ! Flag for some scale-aware mass-flux convection scheme active + ltaerosol, & ! Flag for aerosol option do_mynnedmf ! Flag to activate MYNN-EDMF real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant @@ -133,7 +129,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel tracer(1:nCol,1:nLev,i_cldgrpl) - ! Cloud particle size + ! Cloud water path (g/m2) deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. do iLay = 1, nLev do iCol = 1, nCol @@ -146,22 +142,23 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do enddo enddo + ! Cloud particle sizes and number concentrations... + ! First, prepare cloud mixing-ratios and number concentrations for Calc_Re rho = p_lay(1:nCol,1:nLev)/(con_rd*t_lay(1:nCol,1:nLev)) orho = 1./rho do iLay = 1, nLev do iCol = 1, nCol qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) - qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) - qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) - qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) - nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) + qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) + qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) + nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) if (ltaerosol) then - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) else nc_mp(iCol,iLay) = nt_c*orho(iCol,iLay) - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) endif enddo enddo @@ -201,7 +198,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do if (uni_cld) then cld_frac(1:nCol,1:nLev) = cld_frac_mg(1:nCol,1:nLev) else - if( lmfshal) alpha0 = 100. ! Default + if( lmfshal) alpha0 = 100. ! Default (from GATE simulations) if(.not. lmfshal) alpha0 = 2000. ! Xu-Randall (1996) cloud-fraction do iLay = 1, nLev @@ -242,10 +239,13 @@ function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) relhum, & ! Relative humidity cld_mr, & ! Total cloud mixing ratio alpha ! Scheme parameter (default=100) + ! Outputs real(kind_phys) :: cld_frac_XuRandall + ! Locals real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 + ! Parameters real(kind_phys) :: & lambda = 0.50, & ! From e2143c4b0cc7f3c9550b3258029ac8dbbb2726f2 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 16 Nov 2020 14:45:39 -0700 Subject: [PATCH 06/67] Added option for including scattering in LW clouds. --- physics/rrtmgp_lw_cloud_optics.F90 | 47 +++++++------ physics/rrtmgp_lw_cloud_optics.meta | 12 +++- physics/rrtmgp_lw_cloud_sampling.F90 | 19 ++--- physics/rrtmgp_lw_cloud_sampling.meta | 16 +++-- physics/rrtmgp_lw_rte.F90 | 99 ++++++++++++++++++--------- physics/rrtmgp_lw_rte.meta | 14 +++- physics/rrtmgp_sampling.F90 | 9 ++- physics/rrtmgp_sw_cloud_optics.F90 | 16 ++--- physics/rrtmgp_sw_cloud_sampling.F90 | 4 +- 9 files changed, 152 insertions(+), 84 deletions(-) diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index f45f08dd1..a7aeecffe 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -3,7 +3,7 @@ module rrtmgp_lw_cloud_optics use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl + use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str use mo_rrtmg_lw_cloud_optics, only: rrtmg_lw_cloud_optics use rrtmgp_aux, only: check_error_msg use netcdf @@ -20,14 +20,15 @@ module rrtmgp_lw_cloud_optics contains - ! ######################################################################################### + ! ###################################################################################### ! SUBROUTINE rrtmgp_lw_cloud_optics_init() - ! ######################################################################################### + ! ###################################################################################### !! \section arg_table_rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - nrghice, rrtmgp_root_dir, rrtmgp_lw_file_clouds, mpicomm, mpirank, mpiroot, lw_cloud_props, errmsg, errflg) + subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & + doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_lw_file_clouds, mpicomm, & + mpirank, mpiroot, lw_cloud_props, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -52,7 +53,7 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_ integer, intent(out) :: & errflg ! Error code - ! Variables that will be passed to cloud_optics%load() + ! Local variables that will be passed to cloud_optics%load() real(kind_phys) :: & radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation radliq_upr, & ! Liquid particle size upper bound for LUT interpolation @@ -264,16 +265,16 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_ end subroutine rrtmgp_lw_cloud_optics_init - ! ######################################################################################### + ! ###################################################################################### ! SUBROUTINE rrtmgp_lw_cloud_optics_run() - ! ######################################################################################### + ! ###################################################################################### !! \section arg_table_rrtmgp_lw_cloud_optics_run !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nrghice, p_lay, cld_frac, & - cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, lw_cloud_props, lw_gas_props, lon, lat, cldtaulw, & + subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nrghice, p_lay, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, lw_cloud_props, lw_gas_props, lon, lat, cldtaulw, & lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs @@ -281,7 +282,8 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doLWrad, & ! Logical flag for longwave radiation call doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels @@ -313,7 +315,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error flag - type(ty_optical_props_1scl),intent(out) :: & + type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) real(kind_phys), dimension(ncol,nLev), intent(out) :: & @@ -337,14 +339,19 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! Allocate space for RRTMGP DDTs containing cloud radiative properties ! Cloud optics [nCol,nLev,nBands] - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_1scl(& + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_2str(& ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) lw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys + lw_optical_props_cloudsByBand%ssa(:,:,:) = 0._kind_phys + lw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys + ! Precipitation optics [nCol,nLev,nBands] - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_1scl(& - ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) - lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_2str(& + ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + lw_optical_props_precipByBand%ssa(:,:,:) = 0._kind_phys + lw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys + ! Compute cloud-optics for RTE. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then ! i) RRTMGP cloud-optics. @@ -388,7 +395,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) cldtaulw = lw_optical_props_cloudsByBand%tau(:,:,7) - + end subroutine rrtmgp_lw_cloud_optics_run ! ######################################################################################### diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 809e8abf0..cf0418eb4 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -159,6 +159,14 @@ type = logical intent = in optional = F +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in + optional = F [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -321,7 +329,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = out optional = F [lw_optical_props_precipByBand] @@ -329,7 +337,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = out optional = F [errmsg] diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index cfb86eb3a..7120e125b 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -1,7 +1,7 @@ module rrtmgp_lw_cloud_sampling use machine, only: kind_phys use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl + use mo_optical_props, only: ty_optical_props_2str use rrtmgp_sampling, only: sampled_mask, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_aux, only: check_error_msg @@ -47,12 +47,13 @@ end subroutine rrtmgp_lw_cloud_sampling_init subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, iovr, & iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, lw_gas_props, & - lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, & + doGP_lwscat, lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, & lw_optical_props_clouds, lw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & - doLWrad ! Logical flag for shortwave radiation call + doLWrad, & ! Logical flag for shortwave radiation call + doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical layers @@ -78,7 +79,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, precip_overlap_param ! Precipitation overlap parameter type(ty_gas_optics_rrtmgp),intent(in) :: & lw_gas_props ! RRTMGP DDT: K-distribution data - type(ty_optical_props_1scl),intent(in) :: & + type(ty_optical_props_2str),intent(in) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) @@ -87,7 +88,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - type(ty_optical_props_1scl),intent(out) :: & + type(ty_optical_props_2str),intent(out) :: & lw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (clouds) lw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties by spectral point (precipitation) @@ -112,7 +113,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Allocate space RRTMGP DDTs [nCol,nLev,nGpt] call check_error_msg('rrtmgp_lw_cloud_sampling_run',& - lw_optical_props_clouds%alloc_1scl(nCol, nLev, lw_gas_props)) + lw_optical_props_clouds%alloc_2str(nCol, nLev, lw_gas_props)) ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed @@ -170,7 +171,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(cldfracMCICA, & + draw_samples(cldfracMCICA, doGP_lwscat, & lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) @@ -180,7 +181,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Allocate space RRTMGP DDTs [nCol,nLev,nGpt] call check_error_msg('rrtmgp_lw_cloud_sampling_run',& - lw_optical_props_precip%alloc_1scl(nCol, nLev, lw_gas_props)) + lw_optical_props_precip%alloc_2str(nCol, nLev, lw_gas_props)) ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed @@ -230,7 +231,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& - draw_samples(precipfracSAMP, & + draw_samples(precipfracSAMP, doGP_lwscat, & lw_optical_props_precipByBand, & lw_optical_props_precip)) diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 54f3c63af..2438f715c 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -53,6 +53,14 @@ type = logical intent = in optional = F +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in + optional = F [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -198,7 +206,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = in optional = F [lw_optical_props_precipByBand] @@ -206,7 +214,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = in optional = F [lw_optical_props_clouds] @@ -214,7 +222,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = out optional = F [lw_optical_props_precip] @@ -222,7 +230,7 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str intent = out optional = F [errmsg] diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index dc49260f6..ccbd80629 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -5,7 +5,7 @@ module rrtmgp_lw_rte use mo_rte_kind, only: wl use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_cloud_optics, only: ty_cloud_optics - use mo_optical_props, only: ty_optical_props_1scl + use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str use mo_rte_lw, only: rte_lw use mo_fluxes_byband, only: ty_fluxes_byband use mo_source_functions, only: ty_source_func_lw @@ -28,17 +28,18 @@ end subroutine rrtmgp_lw_rte_init !! \section arg_table_rrtmgp_lw_rte_run !! \htmlinclude rrtmgp_lw_rte_run.html !! - subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, nCol, nLev, p_lay, & - t_lay, p_lev, skt, lw_gas_props, sfc_emiss_byband, sources, lw_optical_props_clrsky,& - lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & - fluxlwDOWN_jac, errmsg, errflg) + subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & + nLev, p_lay, t_lay, p_lev, skt, lw_gas_props, sfc_emiss_byband, sources, & + lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_aerosol, & + nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & + fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwDOWN_jac, errmsg, errflg) ! Inputs logical, intent(in) :: & doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? - use_LW_jacobian ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels @@ -57,10 +58,11 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, nCol, nLev, p type(ty_source_func_lw),intent(in) :: & sources ! RRTMGP DDT: longwave source functions type(ty_optical_props_1scl),intent(inout) :: & + lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol radiative properties lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties - type(ty_optical_props_1scl),intent(in) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud radiative properties - lw_optical_props_aerosol ! RRTMGP DDT: longwave aerosol radiative properties + type(ty_optical_props_2str),intent(inout) :: & + lw_optical_props_clouds ! RRTMGP DDT: longwave cloud radiative properties + ! Outputs real(kind_phys), dimension(ncol,nLev+1), intent(out) :: & fluxlwUP_allsky, & ! All-sky flux (W/m2) @@ -106,6 +108,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, nCol, nLev, p ! ! Add aerosol optics to gas optics call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%increment(lw_optical_props_clrsky)) + !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%finalize()) ! Call RTE solver if (doLWclrsky) then @@ -128,31 +131,61 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, nCol, nLev, p ! ! All-sky fluxes ! - ! Add cloud optics to clear-sky optics - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%increment(lw_optical_props_clrsky)) - ! Call RTE solver - if (use_LW_jacobian) then - ! Compute LW Jacobians - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac, & ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) - flux_dn_Jac = fluxlwDOWN_jac)) ! OUT - surface temperature flux (downward) Jacobian (W/m2/K) + ! Include LW cloud-scattering? + if (doGP_lwscat) then + ! Add clear-sky optics to cloud-optics (2-stream) + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%increment(lw_optical_props_clouds)) + !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%finalize()) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac, & ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + flux_dn_Jac = fluxlwDOWN_jac)) ! OUT - surface temperature flux (downward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + ! No scattering in LW clouds. else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - end if - + ! Add cloud optics to clear-sky optics (scalar) + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%increment(lw_optical_props_clrsky)) + !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%finalize()) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac, & ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + flux_dn_Jac = fluxlwDOWN_jac)) ! OUT - surface temperature flux (downward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + endif + ! Store fluxes fluxlwUP_allsky = sum(flux_allsky%bnd_flux_up,dim=3) fluxlwDOWN_allsky = sum(flux_allsky%bnd_flux_dn,dim=3) diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 857ab834c..7adcc2c74 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -32,6 +32,14 @@ type = logical intent = in optional = F +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in + optional = F [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -122,8 +130,8 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl - intent = in + type = ty_optical_props_2str + intent = inout optional = F [lw_optical_props_aerosol] standard_name = longwave_optical_properties_for_aerosols @@ -131,7 +139,7 @@ units = DDT dimensions = () type = ty_optical_props_1scl - intent = in + intent = inout optional = F [sources] standard_name = longwave_source_function diff --git a/physics/rrtmgp_sampling.F90 b/physics/rrtmgp_sampling.F90 index 29a9064a2..3974da359 100644 --- a/physics/rrtmgp_sampling.F90 +++ b/physics/rrtmgp_sampling.F90 @@ -36,9 +36,10 @@ module rrtmgp_sampling ! McICA-sampled cloud optical properties ! ! ------------------------------------------------------------------------------------------------- - function draw_samples(cloud_mask,clouds,clouds_sampled) result(error_msg) + function draw_samples(cloud_mask,do_twostream,clouds,clouds_sampled) result(error_msg) ! Inputs logical, dimension(:,:,:), intent(in ) :: cloud_mask ! Dimensions ncol,nlay,ngpt + logical, intent(in ) :: do_twostream ! Do two-stream? class(ty_optical_props_arry), intent(in ) :: clouds ! Defined by band ! Outputs @@ -66,8 +67,10 @@ function draw_samples(cloud_mask,clouds,clouds_sampled) result(error_msg) type is (ty_optical_props_2str) select type(clouds_sampled) type is (ty_optical_props_2str) - call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%ssa,clouds_sampled%ssa) - call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%g, clouds_sampled%g ) + if (do_twostream) then + call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%ssa,clouds_sampled%ssa) + call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%g, clouds_sampled%g ) + endif class default error_msg = "draw_samples: by-band and sampled cloud properties need to be the same variable type" end select diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 505fe7853..fec067d9e 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -1,8 +1,8 @@ module rrtmgp_sw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_cloud_optics, only: ty_cloud_optics + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_2str use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics use rrtmgp_aux, only: check_error_msg @@ -20,15 +20,15 @@ module rrtmgp_sw_cloud_optics real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s contains - ! ######################################################################################### + ! ###################################################################################### ! SUBROUTINE sw_cloud_optics_init - ! ######################################################################################### + ! ###################################################################################### !! \section arg_table_rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, mpirank, mpiroot, sw_cloud_props,& - errmsg, errflg) + subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & + doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & + mpirank, mpiroot, sw_cloud_props, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -53,7 +53,7 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_ integer, intent(out) :: & errflg ! CCPP error code - ! Variables that will be passed to cloud_optics%load() + ! Local variables that will be passed to cloud_optics%load() real(kind_phys) :: & radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation radliq_upr, & ! Liquid particle size upper bound for LUT interpolation @@ -276,7 +276,7 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_ c0r = (/0.980, 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, & 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/) c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, & - 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) + 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) end subroutine rrtmgp_sw_cloud_optics_init diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index ba4097e96..e74ceb4e5 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -181,7 +181,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxd ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(cldfracMCICA, & + draw_samples(cldfracMCICA, .true., & sw_optical_props_cloudsByBand, & sw_optical_props_clouds)) @@ -239,7 +239,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxd ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_sw_precip_sampling_run_draw_samples', & - draw_samples(precipfracSAMP, & + draw_samples(precipfracSAMP, .true., & sw_optical_props_precipByBand, & sw_optical_props_precip)) From 92eb240ca610c8dec846e5d4c6774c2ce0e60ddd Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 16 Nov 2020 17:33:50 -0700 Subject: [PATCH 07/67] Added finalize calls to rrtmgp_lw_rte --- physics/rrtmgp_lw_rte.F90 | 6 +++--- physics/rte-rrtmgp | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index ccbd80629..bc7bdd5bd 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -108,7 +108,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, ! ! Add aerosol optics to gas optics call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%increment(lw_optical_props_clrsky)) - !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%finalize()) + call lw_optical_props_aerosol%finalize() ! Call RTE solver if (doLWclrsky) then @@ -136,7 +136,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, if (doGP_lwscat) then ! Add clear-sky optics to cloud-optics (2-stream) call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%increment(lw_optical_props_clouds)) - !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%finalize()) + call lw_optical_props_clrsky%finalize() if (use_LW_jacobian) then ! Compute LW Jacobians @@ -162,7 +162,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, else ! Add cloud optics to clear-sky optics (scalar) call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%increment(lw_optical_props_clrsky)) - !call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%finalize()) + call lw_optical_props_clouds%finalize() if (use_LW_jacobian) then ! Compute LW Jacobians diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 566bee9cd..38822b3cc 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d +Subproject commit 38822b3cc686517ab87a039e5dedd57ebbe527d2 From e0643105f0c540ff268ccd4b317b9a9c31c3893a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 17 Nov 2020 11:08:59 -0700 Subject: [PATCH 08/67] Bug fix in LW Jacobian application --- physics/GFS_suite_interstitial.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 551f0e600..38ea1800a 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -245,10 +245,10 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl if (use_GP_jacobian) then ! Compute adjustment to the surface flux using Jacobian. if(linit_mod) then - dT(:) = (skt(:) - sktp1r(:)) + dT(:) = (sktp1r(:) - skt(:)) adjsfculw(:) = fluxlwUP(:,1) + fluxlwUP_jac(:,1) * dT(:) else - adjsfculw(:) = 0. + adjsfculw(:) = fluxlwUP(:,1) linit_mod = .true. endif From 13ea6a534485be5ee9fcc89e6b17c90d01584428 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 18 Nov 2020 10:45:09 -0700 Subject: [PATCH 09/67] Housekeeping --- physics/rrtmgp_lw_rte.F90 | 15 ++++----------- physics/rrtmgp_lw_rte.meta | 27 --------------------------- 2 files changed, 4 insertions(+), 38 deletions(-) diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index bc7bdd5bd..cf85aa7f2 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -29,10 +29,10 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, p_lay, t_lay, p_lev, skt, lw_gas_props, sfc_emiss_byband, sources, & - lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_aerosol, & - nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & - fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwDOWN_jac, errmsg, errflg) + nLev, p_lev, lw_gas_props, sfc_emiss_byband, sources, lw_optical_props_clrsky, & + lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & + fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwDOWN_jac,& + errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -44,13 +44,8 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nGauss_angles ! Number of angles used in Gaussian quadrature - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (hPa) - t_lay ! Temperature (K) real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (hPa) - real(kind_phys), dimension(ncol), intent(in) :: & - skt ! Surface(skin) temperature (K) type(ty_gas_optics_rrtmgp),intent(in) :: & lw_gas_props ! RRTMGP DDT: longwave spectral information real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & @@ -79,8 +74,6 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, fluxlwDOWN_jac ! Jacobian of downward LW flux (W/m2/K) ! Local variables - integer :: & - iCol, iBand, iLay type(ty_fluxes_byband) :: & flux_allsky, flux_clrsky real(kind_phys), dimension(ncol,nLev+1,lw_gas_props%get_nband()),target :: & diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 7adcc2c74..443792edf 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -64,15 +64,6 @@ type = integer intent = in optional = F -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa - long_name = air pressure layer - units = hPa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure level @@ -82,24 +73,6 @@ kind = kind_phys intent = in optional = F -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[skt] - standard_name = surface_ground_temperature_for_radiation - long_name = surface ground temperature for radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [sfc_emiss_byband] standard_name = surface_emissivity_in_each_RRTMGP_LW_band long_name = surface emissivity in each RRTMGP LW band From 567b003bce2171da350c883c3b31dca43c261998 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 18 Nov 2020 12:21:50 -0700 Subject: [PATCH 10/67] Add guard against out-of-range effective radii used by LUTs in GP cloud-optics. --- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 11 ++++++++++- physics/GFS_rrtmgp_thompsonmp_pre.meta | 2 +- physics/rrtmgp_lw_cloud_optics.F90 | 13 +++++++++---- physics/rrtmgp_sw_cloud_optics.F90 | 13 +++++++++---- 4 files changed, 29 insertions(+), 10 deletions(-) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index 8b63090c0..a4dbac22c 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -14,6 +14,7 @@ module GFS_rrtmgp_thompsonmp_pre make_IceNumber, & make_DropletNumber, & make_RainNumber + use rrtmgp_lw_cloud_optics, only: radliq_lwr, radliq_upr, radice_lwr, radice_upr implicit none ! Parameters specific to THOMPSON MP scheme. @@ -183,10 +184,18 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) enddo - ! Scale Thompson's effective radii from meter to micron and update global effective radii. + ! Scale Thompson's effective radii from meter to micron effrin_cldliq(1:nCol,1:nLev) = re_cloud(1:nCol,1:nLev)*1.e6 effrin_cldice(1:nCol,1:nLev) = re_ice(1:nCol,1:nLev)*1.e6 effrin_cldsnow(1:nCol,1:nLev) = re_snow(1:nCol,1:nLev)*1.e6 + + ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from + ! 2.5 - 21.5 microns for liquid clouds, + ! 10 - 180 microns for ice-clouds + effrin_cldliq = max(radliq_lwr, effrin_cldliq, radliq_upr) + effrin_cldice = max(radice_lwr, effrin_cldice, radice_upr) + + ! Update global effective radii arrays. cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index b00e27fd8..e3baf1f6f 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_thompsonmp_pre type = scheme - dependencies = rrtmgp_aux.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90 + dependencies = rrtmgp_aux.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index a7aeecffe..1086cee7c 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -17,6 +17,11 @@ module rrtmgp_lw_cloud_optics absrain = 0.33e-3, & ! Rain drop absorption coefficient \f$(m^{2}/g)\f$ . abssnow0 = 1.5, & ! Snow flake absorption coefficient (micron), fu coeff abssnow1 = 2.34e-3 ! Snow flake absorption coefficient \f$(m^{2}/g)\f$, ncar coef + real(kind_phys) :: & + radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation + radliq_upr, & ! Liquid particle size upper bound for LUT interpolation + radice_lwr, & ! Ice particle size upper bound for LUT interpolation + radice_upr ! Ice particle size lower bound for LUT interpolation contains @@ -55,11 +60,11 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! Local variables that will be passed to cloud_optics%load() real(kind_phys) :: & - radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - radliq_upr, & ! Liquid particle size upper bound for LUT interpolation + !radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation + !radliq_upr, & ! Liquid particle size upper bound for LUT interpolation radliq_fac, & ! Factor for calculating LUT interpolation indices for liquid - radice_lwr, & ! Ice particle size upper bound for LUT interpolation - radice_upr, & ! Ice particle size lower bound for LUT interpolation + !radice_lwr, & ! Ice particle size upper bound for LUT interpolation + !radice_upr, & ! Ice particle size lower bound for LUT interpolation radice_fac ! Factor for calculating LUT interpolation indices for ice real(kind_phys), dimension(:,:), allocatable :: & lut_extliq, & ! LUT shortwave liquid extinction coefficient diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index fec067d9e..92f007a99 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -18,6 +18,11 @@ module rrtmgp_sw_cloud_optics a0s = 0.0, & ! a1s = 1.5 ! real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s + real(kind_phys) :: & + radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation + radliq_upr, & ! Liquid particle size upper bound for LUT interpolation + radice_lwr, & ! Ice particle size upper bound for LUT interpolation + radice_upr ! Ice particle size lower bound for LUT interpolation contains ! ###################################################################################### @@ -55,11 +60,11 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! Local variables that will be passed to cloud_optics%load() real(kind_phys) :: & - radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - radliq_upr, & ! Liquid particle size upper bound for LUT interpolation + !radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation + !radliq_upr, & ! Liquid particle size upper bound for LUT interpolation radliq_fac, & ! Factor for calculating LUT interpolation indices for liquid - radice_lwr, & ! Ice particle size upper bound for LUT interpolation - radice_upr, & ! Ice particle size lower bound for LUT interpolation + !radice_lwr, & ! Ice particle size upper bound for LUT interpolation + !radice_upr, & ! Ice particle size lower bound for LUT interpolation radice_fac ! Factor for calculating LUT interpolation indices for ice real(kind_phys), dimension(:,:), allocatable :: & lut_extliq, & ! LUT shortwave liquid extinction coefficient From 26bd34afdc36c4468d2f1d7ed2f501862ad2c1f9 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 18 Nov 2020 12:43:18 -0700 Subject: [PATCH 11/67] Bug in previous commit --- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index a4dbac22c..710c75ef8 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -192,9 +192,11 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from ! 2.5 - 21.5 microns for liquid clouds, ! 10 - 180 microns for ice-clouds - effrin_cldliq = max(radliq_lwr, effrin_cldliq, radliq_upr) - effrin_cldice = max(radice_lwr, effrin_cldice, radice_upr) - + where(effrin_cldliq .lt. radliq_lwr) effrin_cldliq = radliq_lwr + where(effrin_cldliq .gt. radliq_upr) effrin_cldliq = radliq_upr + where(effrin_cldice .lt. radice_lwr) effrin_cldice = radice_lwr + where(effrin_cldice .gt. radice_upr) effrin_cldice = radice_upr + ! Update global effective radii arrays. cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) From f81a1943629cb6158dd8f514e4ab330ed5ecf578 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 18 Nov 2020 14:12:53 -0700 Subject: [PATCH 12/67] Added logic to pnly guard effective radii when using GP cloud-optics. --- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 16 ++++++++++------ physics/GFS_rrtmgp_thompsonmp_pre.meta | 18 +++++++++++++++++- 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index 710c75ef8..bd109ddf4 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -39,7 +39,7 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do i_cldice_nc, i_twa, effr_in, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, & effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, cld_frac_mg, con_g, & con_rd, uni_cld, lmfshal, lmfdeep2, ltaerosol, do_mynnedmf, imfdeepcnv, & - imfdeepcnv_gf, & + imfdeepcnv_gf, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, errmsg, errflg) @@ -68,7 +68,9 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall lmfdeep2, & ! Flag for some scale-aware mass-flux convection scheme active ltaerosol, & ! Flag for aerosol option - do_mynnedmf ! Flag to activate MYNN-EDMF + do_mynnedmf, & ! Flag to activate MYNN-EDMF + doGP_cldoptics_LUT,& ! Flag to do GP cloud-optics (LUTs) + doGP_cldoptics_PADE ! (PADE approximation) real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd ! Physical constant: gas-constant for dry air @@ -192,10 +194,12 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from ! 2.5 - 21.5 microns for liquid clouds, ! 10 - 180 microns for ice-clouds - where(effrin_cldliq .lt. radliq_lwr) effrin_cldliq = radliq_lwr - where(effrin_cldliq .gt. radliq_upr) effrin_cldliq = radliq_upr - where(effrin_cldice .lt. radice_lwr) effrin_cldice = radice_lwr - where(effrin_cldice .gt. radice_upr) effrin_cldice = radice_upr + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + where(effrin_cldliq .lt. radliq_lwr) effrin_cldliq = radliq_lwr + where(effrin_cldliq .gt. radliq_upr) effrin_cldliq = radliq_upr + where(effrin_cldice .lt. radice_lwr) effrin_cldice = radice_lwr + where(effrin_cldice .gt. radice_upr) effrin_cldice = radice_upr + endif ! Update global effective radii arrays. cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index e3baf1f6f..2368a7337 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -226,7 +226,23 @@ dimensions = () type = integer intent = in - optional = F + optional = F +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in + optional = F +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in + optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure at vertical interface for radiation calculation From cfc437e6ad5d37400ac01fe022e54b3323a15b02 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 24 Nov 2020 11:31:34 -0700 Subject: [PATCH 13/67] Some changes tot est in UFS. --- physics/GFS_rrtmgp_lw_post.F90 | 10 +++--- physics/GFS_rrtmgp_lw_post.meta | 12 ++++---- physics/GFS_rrtmgp_pre.F90 | 46 +++++++++++++++++++++++----- physics/GFS_rrtmgp_pre.meta | 8 +++++ physics/rrtmgp_lw_cloud_optics.F90 | 10 +++--- physics/rrtmgp_lw_cloud_sampling.F90 | 8 +++-- physics/rrtmgp_lw_gas_optics.F90 | 10 +++--- physics/rrtmgp_lw_gas_optics.meta | 2 +- 8 files changed, 75 insertions(+), 31 deletions(-) diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index 537ce8879..e6f6a59a5 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -65,12 +65,12 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(out) :: & + real(kind_phys), dimension(nCol), intent(inout) :: & sfcdlw, & ! Total sky sfc downward lw flux (W/m2) tsflw ! surface air temp during lw calculation (K) - type(sfcflw_type), dimension(nCol), intent(out) :: & + type(sfcflw_type), dimension(nCol), intent(inout) :: & sfcflw ! LW radiation fluxes at sfc - real(kind_phys), dimension(nCol,nLev), intent(out) :: & + real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw ! LW all-sky heating rate type(topflw_type), dimension(nCol), intent(out) :: & topflw ! lw_fluxes_top_atmosphere @@ -80,13 +80,13 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag errflg ! Outputs (optional) - type(proflw_type), dimension(nCol, nLev+1), optional, intent(out) :: & + type(proflw_type), dimension(nCol, nLev+1), optional, intent(inout) :: & flxprf_lw ! 2D radiative fluxes, components: ! upfxc - total sky upward flux (W/m2) ! dnfxc - total sky dnward flux (W/m2) ! upfx0 - clear sky upward flux (W/m2) ! dnfx0 - clear sky dnward flux (W/m2) - real(kind_phys),dimension(nCol, nLev),intent(out),optional :: & + real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrlwc ! Longwave clear-sky heating-rate (K/sec) ! Local variables diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta index 2218bc55e..a87b6adcb 100644 --- a/physics/GFS_rrtmgp_lw_post.meta +++ b/physics/GFS_rrtmgp_lw_post.meta @@ -196,7 +196,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [sfcflw] standard_name = lw_fluxes_sfc @@ -204,7 +204,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = sfcflw_type - intent = out + intent = inout optional = F [tsflw] standard_name = surface_midlayer_air_temperature_in_longwave_radiation @@ -213,7 +213,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [htrlw] standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step @@ -222,7 +222,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [topflw] standard_name = lw_fluxes_top_atmosphere @@ -238,7 +238,7 @@ units = W m-2 dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = proflw_type - intent = out + intent = inout optional = T [htrlwc] standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step @@ -247,7 +247,7 @@ dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys - intent = out + intent = inout optional = T [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index f4542dffb..35e1eb67c 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -145,7 +145,7 @@ end subroutine GFS_rrtmgp_pre_init !! subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, fhswr, & fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, active_gases_array, con_eps,& - con_epsm1, con_fvirt, con_epsqs, & + con_epsm1, con_fvirt, con_epsqs, lw_gas_props, & raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer,& gas_concentrations, errmsg, errflg) @@ -181,6 +181,8 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, prsi ! Pressure at model-interfaces (Pa) real(kind_phys), dimension(nCol,nLev,nTracers) :: & qgrs ! Tracer concentrations (kg/kg) + type(ty_gas_optics_rrtmgp),intent(in) :: & + lw_gas_props ! RRTMGP DDT: ! Outputs character(len=*), intent(out) :: & @@ -198,7 +200,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, q_lay, & ! Water-vapor mixing ratio (kg/kg) tv_lay, & ! Virtual temperature at model-layers relhum, & ! Relative-humidity at model-layers - qs_lay ! Saturation vapor pressure at model-layers + qs_lay ! Saturation vapor pressure at model-layers real(kind_phys), dimension(nCol,nLev+1), intent(out) :: & p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface @@ -212,7 +214,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, logical :: top_at_1 real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2 - real(kind_phys), dimension(nCol,nLev) :: o3_lay + real(kind_phys), dimension(nCol,nLev) :: o3_lay, tem2da, tem2db real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr ! Initialize CCPP error handling variables @@ -250,14 +252,44 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, ! Temperature at layer-center t_lay(1:NCOL,:) = tgrs(1:NCOL,:) - ! Temperature at layer-interfaces + ! Temperature at layer-interfaces if (top_at_1) then + tem2da(1:nCol,2:iSFC) = log(p_lay(1:nCol,2:iSFC)) + tem2db(1:nCol,2:iSFC) = log(p_lev(1:nCol,2:iSFC)) + do iCol = 1, nCol + tem2da(iCol,1) = log(p_lay(iCol,1) ) + tem2db(iCol,1) = log(max(lw_gas_props%get_press_min(), p_lev(iCol,1)) ) + tem2db(iCol,iSFC) = log(p_lev(iCol,iSFC) ) + enddo + ! t_lev(1:NCOL,1) = t_lay(1:NCOL,iTOA) - t_lev(1:NCOL,2:iSFC) = (t_lay(1:NCOL,2:iSFC)+t_lay(1:NCOL,1:iSFC-1))/2._kind_phys + do iLay = 2, iSFC + do iCol = 1, nCol + t_lev(iCol,iLay) = t_lay(iCol,iLay) + (t_lay(iCol,iLay-1) - t_lay(iCol,iLay))& + * (tem2db(iCol,iLay) - tem2da(iCol,iLay)) & + / (tem2da(iCol,iLay-1) - tem2da(iCol,iLay)) + enddo + enddo + !t_lev(1:NCOL,2:iSFC) = (t_lay(1:NCOL,2:iSFC)+t_lay(1:NCOL,1:iSFC-1))/2._kind_phys t_lev(1:NCOL,iSFC+1) = tsfc(1:NCOL) else + tem2da(1:nCol,2:iTOA) = log(p_lay(1:nCol,2:iTOA)) + tem2db(1:nCol,2:iTOA) = log(p_lev(1:nCol,2:iTOA)) + do iCol = 1, nCol + tem2da(iCol,1) = log(p_lay(iCol,1)) + tem2db(iCol,1) = log(p_lev(iCol,1)) + tem2db(iCol,iTOA) = log(max(lw_gas_props%get_press_min(), p_lev(iCol,iTOA)) ) + enddo + ! t_lev(1:NCOL,1) = tsfc(1:NCOL) - t_lev(1:NCOL,2:iTOA) = (t_lay(1:NCOL,2:iTOA)+t_lay(1:NCOL,1:iTOA-1))/2._kind_phys + do iLay = 1, iTOA-1 + do iCol = 1, nCol + t_lev(iCol,iLay+1) = t_lay(iCol,iLay) + (t_lay(iCol,iLay+1) - t_lay(iCol,iLay))& + * (tem2db(iCol,iLay+1) - tem2da(iCol,iLay)) & + / (tem2da(iCol,iLay+1) - tem2da(iCol,iLay)) + enddo + enddo + !t_lev(1:NCOL,2:iTOA) = (t_lay(1:NCOL,2:iTOA)+t_lay(1:NCOL,1:iTOA-1))/2._kind_phys t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) endif @@ -321,7 +353,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### tsfg(1:NCOL) = tsfc(1:NCOL) - tsfa(1:NCOL) = tsfc(1:NCOL) + tsfa(1:NCOL) = t_lay(1:NCOL,iSFC)!tsfc(1:NCOL) end subroutine GFS_rrtmgp_pre_run diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 904c0e4e7..136898bb3 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -247,6 +247,14 @@ kind = kind_phys intent = in optional = F +[lw_gas_props] + standard_name = coefficients_for_lw_gas_optics + long_name = DDT containing spectral information for RRTMGP LW radiation scheme + units = DDT + dimensions = () + type = ty_gas_optics_rrtmgp + intent = in + optional = F [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 1086cee7c..023df62ec 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -347,14 +347,14 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_2str(& ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) lw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - lw_optical_props_cloudsByBand%ssa(:,:,:) = 0._kind_phys + lw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys lw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys ! Precipitation optics [nCol,nLev,nBands] call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_2str(& ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - lw_optical_props_precipByBand%ssa(:,:,:) = 0._kind_phys + lw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys lw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys ! Compute cloud-optics for RTE. @@ -393,9 +393,9 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw call rrtmg_lw_cloud_optics(ncol, nLev, lw_gas_props%get_nband(), cld_lwp, & cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain, cld_swp, cld_resnow, & cld_frac, icliq_lw, icice_lw, tau_cld, tau_precip) - endif - lw_optical_props_cloudsByBand%tau = tau_cld - lw_optical_props_precipByBand%tau = tau_precip + lw_optical_props_cloudsByBand%tau = tau_cld + lw_optical_props_precipByBand%tau = tau_precip + endif endif ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 7120e125b..902a4e20f 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -12,7 +12,7 @@ module rrtmgp_lw_cloud_sampling contains ! ######################################################################################### - ! SUBROUTINE mcica_init + ! SUBROUTINE rrtmgp_lw_cloud_sampling_init() ! ######################################################################################### !! \section arg_table_rrtmgp_lw_cloud_sampling_init !! \htmlinclude rrtmgp_lw_cloud_sampling_init.html @@ -97,8 +97,8 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, integer,dimension(ncol) :: ipseed_lw type(random_stat) :: rng_stat real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLev,ncol) :: rng3D,rng3D2 - real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLev) :: rng2D + real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: cldfracMCICA,precipfracSAMP ! Initialize CCPP error handling variables @@ -114,6 +114,8 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Allocate space RRTMGP DDTs [nCol,nLev,nGpt] call check_error_msg('rrtmgp_lw_cloud_sampling_run',& lw_optical_props_clouds%alloc_2str(nCol, nLev, lw_gas_props)) + lw_optical_props_clouds%tau(:,:,:) = 0._kind_phys + lw_optical_props_clouds%ssa(:,:,:) = 0._kind_phys ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed @@ -182,6 +184,8 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! Allocate space RRTMGP DDTs [nCol,nLev,nGpt] call check_error_msg('rrtmgp_lw_cloud_sampling_run',& lw_optical_props_precip%alloc_2str(nCol, nLev, lw_gas_props)) + lw_optical_props_precip%tau(:,:,:) = 0._kind_phys + lw_optical_props_precip%ssa(:,:,:) = 0._kind_phys ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 787db6bb4..813699ae0 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -282,7 +282,7 @@ end subroutine rrtmgp_lw_gas_optics_init !! \htmlinclude rrtmgp_lw_gas_optics_run.html !! subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_lev, t_lay,& - t_lev, skt, gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) + t_lev, tsfg, gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -299,7 +299,7 @@ subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_ p_lev, & ! Pressure @ model layer-interfaces (hPa) t_lev ! Temperature @ model levels real(kind_phys), dimension(ncol), intent(in) :: & - skt ! Surface(skin) temperature (K) + tsfg ! Surface ground temperature (K) type(ty_gas_concs),intent(in) :: & gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) @@ -328,11 +328,11 @@ subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_ p_lay, & ! IN - Pressure @ layer-centers (Pa) p_lev, & ! IN - Pressure @ layer-interfaces (Pa) t_lay, & ! IN - Temperature @ layer-centers (K) - skt, & ! IN - Skin-temperature (K) + tsfg, & ! IN - Skin-temperature (K) gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) + sources))!, & ! OUT - RRTMGP DDT: source functions + !tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) end subroutine rrtmgp_lw_gas_optics_run diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 92d475d24..3eab78be2 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -165,7 +165,7 @@ kind = kind_phys intent = in optional = F -[skt] +[tsfg] standard_name = surface_ground_temperature_for_radiation long_name = surface ground temperature for radiation units = K From 6d08e55946d8566243a42b95f4506e74c3b96821 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 24 Nov 2020 14:28:03 -0700 Subject: [PATCH 14/67] Updated rte-rrtmgp --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 566bee9cd..33c8a984c 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d +Subproject commit 33c8a984c17cf41be5d4c2928242e1b4239bfc40 From 610c6e30512c7a5ecdbf34c6657f60c619491538 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 2 Dec 2020 10:53:54 -0700 Subject: [PATCH 15/67] Some cleanup --- physics/GFS_rrtmgp_pre.F90 | 6 ++---- physics/rrtmgp_lw_gas_optics.F90 | 4 ++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 35e1eb67c..25f65567a 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -269,8 +269,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, * (tem2db(iCol,iLay) - tem2da(iCol,iLay)) & / (tem2da(iCol,iLay-1) - tem2da(iCol,iLay)) enddo - enddo - !t_lev(1:NCOL,2:iSFC) = (t_lay(1:NCOL,2:iSFC)+t_lay(1:NCOL,1:iSFC-1))/2._kind_phys + enddo t_lev(1:NCOL,iSFC+1) = tsfc(1:NCOL) else tem2da(1:nCol,2:iTOA) = log(p_lay(1:nCol,2:iTOA)) @@ -288,8 +287,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, * (tem2db(iCol,iLay+1) - tem2da(iCol,iLay)) & / (tem2da(iCol,iLay+1) - tem2da(iCol,iLay)) enddo - enddo - !t_lev(1:NCOL,2:iTOA) = (t_lay(1:NCOL,2:iTOA)+t_lay(1:NCOL,1:iTOA-1))/2._kind_phys + enddo t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) endif diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 813699ae0..f8a01b982 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -331,8 +331,8 @@ subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_ tsfg, & ! IN - Skin-temperature (K) gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources))!, & ! OUT - RRTMGP DDT: source functions - !tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) + sources, & ! OUT - RRTMGP DDT: source functions + tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) end subroutine rrtmgp_lw_gas_optics_run From c346d074426f9eb12762df7c0b5a8164554eb57a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Dec 2020 09:22:11 -0700 Subject: [PATCH 16/67] Fixed bug in argument intent for GP SW routines. --- physics/GFS_rrtmgp_sw_post.F90 | 14 +++++++------- physics/GFS_rrtmgp_sw_post.meta | 32 ++++++++++++++++---------------- physics/GFS_rrtmgp_sw_pre.F90 | 20 +++++++++----------- physics/GFS_rrtmgp_sw_pre.meta | 21 +++++++++++++++------ physics/rrtmgp_lw_pre.F90 | 9 +++++---- physics/rrtmgp_lw_pre.meta | 15 ++++++++++++--- 6 files changed, 64 insertions(+), 47 deletions(-) diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 3a9871a5c..f89c2e7e7 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -77,7 +77,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky cldtausw ! approx .55mu band layer cloud optical depth ! Inputs (optional) - type(cmpfsw_type), dimension(nCol), intent(in), optional :: & + type(cmpfsw_type), dimension(nCol), intent(inout), optional :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux at (W/m2) ! uvbf0 - clear sky downward uv-b flux at (W/m2) @@ -89,7 +89,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(out) :: & + real(kind_phys), dimension(nCol), intent(inout) :: & nirbmdi, & ! sfc nir beam sw downward flux (W/m2) nirdfdi, & ! sfc nir diff sw downward flux (W/m2) visbmdi, & ! sfc uv+vis beam sw downward flux (W/m2) @@ -100,11 +100,11 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) sfcnsw, & ! total sky sfc netsw flx into ground sfcdsw ! - real(kind_phys), dimension(nCol,nLev), intent(out) :: & + real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrsw ! SW all-sky heating rate - type(sfcfsw_type), dimension(nCol), intent(out) :: & + type(sfcfsw_type), dimension(nCol), intent(inout) :: & sfcfsw ! sw radiation fluxes at sfc - type(topfsw_type), dimension(nCol), intent(out) :: & + type(topfsw_type), dimension(nCol), intent(inout) :: & topfsw ! sw_fluxes_top_atmosphere character(len=*), intent(out) :: & errmsg @@ -112,13 +112,13 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky errflg ! Outputs (optional) - type(profsw_type), dimension(nCol, nLev), intent(out), optional :: & + type(profsw_type), dimension(nCol, nLev), intent(inout), optional :: & flxprf_sw ! 2D radiative fluxes, components: ! upfxc - total sky upward flux (W/m2) ! dnfxc - total sky dnward flux (W/m2) ! upfx0 - clear sky upward flux (W/m2) ! dnfx0 - clear sky dnward flux (W/m2) - real(kind_phys),dimension(nCol, nLev),intent(out),optional :: & + real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrswc ! Clear-sky heating rate (K/s) ! Local variables diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 77f7b15a6..2dc412118 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -266,7 +266,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [nirdfdi] standard_name = surface_downwelling_diffuse_near_infrared_shortwave_flux_on_radiation_time_step @@ -275,7 +275,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [visbmdi] standard_name = surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_on_radiation_time_step @@ -284,7 +284,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [visdfdi] standard_name = surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_on_radiation_time_step @@ -293,7 +293,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [nirbmui] standard_name = surface_upwelling_direct_near_infrared_shortwave_flux_on_radiation_time_step @@ -302,7 +302,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [nirdfui] standard_name = surface_upwelling_diffuse_near_infrared_shortwave_flux_on_radiation_time_step @@ -311,7 +311,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [visbmui] standard_name = surface_upwelling_direct_ultraviolet_and_visible_shortwave_flux_on_radiation_time_step @@ -320,7 +320,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [visdfui] standard_name = surface_upwelling_diffuse_ultraviolet_and_visible_shortwave_flux_on_radiation_time_step @@ -329,7 +329,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [sfcnsw] standard_name = surface_net_downwelling_shortwave_flux_on_radiation_time_step @@ -338,7 +338,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [sfcdsw] standard_name = surface_downwelling_shortwave_flux_on_radiation_time_step @@ -347,7 +347,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [htrsw] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step @@ -356,7 +356,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [sfcfsw] standard_name = sw_fluxes_sfc @@ -364,7 +364,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = sfcfsw_type - intent = out + intent = inout optional = F [topfsw] standard_name = sw_fluxes_top_atmosphere @@ -372,7 +372,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = topfsw_type - intent = out + intent = inout optional = F [htrswc] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky_on_radiation_time_step @@ -381,7 +381,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [flxprf_sw] standard_name = RRTMGP_sw_fluxes @@ -389,7 +389,7 @@ units = W m-2 dimensions = (horizontal_loop_extent,adjusted_vertical_level_dimension_plus_one) type = profsw_type - intent = out + intent = inout optional = T [scmpsw] standard_name = components_of_surface_downward_shortwave_fluxes @@ -397,7 +397,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = cmpfsw_type - intent = in + intent = inout optional = T [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 index 179c622f5..1268ed26f 100644 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ b/physics/GFS_rrtmgp_sw_pre.F90 @@ -27,12 +27,11 @@ end subroutine GFS_rrtmgp_sw_pre_init !! \htmlinclude GFS_rrtmgp_sw_pre.html !! subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_list, & - lndp_prt_list, doSWrad, solhr, & - lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, tsfc, hprime, alvsf, & - alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, lsmask, sfc_wts, p_lay, tv_lay, & - relhum, p_lev, sw_gas_props, & - nday, idxday, coszen, coszdg, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_dif, errmsg, errflg) + lndp_prt_list, doSWrad, solhr, lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, & + tsfg, tsfa, hprime, alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, lsmask, & + sfc_wts, p_lay, tv_lay, relhum, p_lev, sw_gas_props, nday, idxday, coszen, coszdg, & + sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_dif, & + errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -58,7 +57,8 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_ sncovr, & ! Surface snow area fraction (frac) snoalb, & ! Maximum snow albedo (frac) zorl, & ! Surface roughness length (cm) - tsfc, & ! Surface skin temperature (K) + tsfg, & ! Surface ground temperature for radiation (K) + tsfa, & ! Lowest model layer air temperature for radiation (K) hprime, & ! Standard deviation of subgrid orography (m) alvsf, & ! Mean vis albedo with strong cosz dependency (frac) alnsf, & ! Mean nir albedo with strong cosz dependency (frac) @@ -84,7 +84,7 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_ nday ! Number of daylit points integer, dimension(ncol), intent(out) :: & idxday ! Indices for daylit points - real(kind_phys), dimension(ncol), intent(out) :: & + real(kind_phys), dimension(ncol), intent(inout) :: & coszen, & ! Cosine of SZA coszdg, & ! Cosine of SZA, daytime sfc_alb_dif ! Mean surface diffused (nIR+uvvis) sw albedo @@ -132,7 +132,7 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_ ! #################################################################################### alb1d(:) = 0. lndp_alb = -999. - call setalb (lsmask, snowd, sncovr, snoalb, zorl, coszen, tsfc, tsfc, hprime, alvsf, & + call setalb (lsmask, snowd, sncovr, snoalb, zorl, coszen, tsfg, tsfa, hprime, alvsf, & alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, NCOL, alb1d, lndp_alb, sfcalb) ! Approximate mean surface albedo from vis- and nir- diffuse values. @@ -148,8 +148,6 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_ else nday = 0 idxday = 0 - coszen(1:nCol) = 0. - coszdg(1:nCol) = 0. sfc_alb_nir_dir(:,1:nCol) = 0. sfc_alb_nir_dif(:,1:nCol) = 0. sfc_alb_uvvis_dir(:,1:nCol) = 0. diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta index b24ab5710..202f1667a 100644 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ b/physics/GFS_rrtmgp_sw_pre.meta @@ -154,15 +154,24 @@ kind = kind_phys intent = in optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature +[tsfg] + standard_name = surface_ground_temperature_for_radiation + long_name = surface ground temperature for radiation units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in optional = F +[tsfa] + standard_name = surface_air_temperature_for_radiation + long_name = lowest model layer air temperature for radiation + units = K + 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 @@ -356,7 +365,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [coszdg] standard_name = daytime_mean_cosz_over_rad_call_period @@ -365,7 +374,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [sfc_alb_dif] standard_name = surface_diffused_shortwave_albedo @@ -374,7 +383,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [errmsg] standard_name = ccpp_error_message diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 index caee7308e..358e49bee 100644 --- a/physics/rrtmgp_lw_pre.F90 +++ b/physics/rrtmgp_lw_pre.F90 @@ -24,8 +24,8 @@ end subroutine rrtmgp_lw_pre_init !> \section arg_table_rrtmgp_lw_pre_run !! \htmlinclude rrtmgp_lw_pre_run.html !! - subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, sncovr, tsfc, & - hprime, lw_gas_props, sfc_emiss_byband, semis, errmsg, errflg) + subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, sncovr, & + tsfg, tsfa, hprime, lw_gas_props, sfc_emiss_byband, semis, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -39,7 +39,8 @@ subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, snc zorl, & ! Surface roughness length (cm) snowd, & ! water equivalent snow depth (mm) sncovr, & ! Surface snow are fraction (1) - tsfc, & ! Surface skin temperature (K) + tsfg, & ! Surface ground temperature for radiation (K) + tsfa, & ! Lowest model layer air temperature for radiation (K) hprime ! Standard deviation of subgrid orography type(ty_gas_optics_rrtmgp),intent(in) :: & lw_gas_props ! RRTMGP DDT: spectral information for LW calculation @@ -66,7 +67,7 @@ subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, snc ! ####################################################################################### ! Call module_radiation_surface::setemis(),to setup surface emissivity for LW radiation. ! ####################################################################################### - call setemis (xlon, xlat, slmsk, snowd, sncovr, zorl, tsfc, tsfc, hprime, nCol, semis) + call setemis (xlon, xlat, slmsk, snowd, sncovr, zorl, tsfg, tsfa, hprime, nCol, semis) ! Assign same emissivity to all bands do iBand=1,lw_gas_props%get_nband() diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index 8084ecf90..1f329dd8d 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -77,15 +77,24 @@ kind = kind_phys intent = in optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature +[tsfg] + standard_name = surface_ground_temperature_for_radiation + long_name = surface ground temperature for radiation units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in optional = F +[tsfa] + standard_name = surface_air_temperature_for_radiation + long_name = lowest model layer air temperature for radiation + units = K + 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 From 95e8fd9f218374d869f3481a7964431155c0f008 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Dec 2020 11:22:11 -0700 Subject: [PATCH 17/67] Moved use of LW jacobian for adjustment into dcyc2.f --- physics/GFS_suite_interstitial.F90 | 31 ++----------------- physics/GFS_suite_interstitial.meta | 46 +---------------------------- physics/dcyc2.f | 43 +++++++++++++++++---------- physics/dcyc2.meta | 26 ++++++++++++++++ physics/rrtmgp_lw_rte.F90 | 10 +++---- physics/rrtmgp_lw_rte.meta | 4 +-- 6 files changed, 64 insertions(+), 96 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 38ea1800a..c5d203457 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -163,7 +163,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_GP_jacobian, skt, sktp1r, fluxlwUP, fluxlwUP_jac, errmsg, errflg) + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, errmsg, errflg) implicit none @@ -184,17 +184,6 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat real(kind=kind_phys), intent( out), dimension(im) :: adjsfculw - - ! RRTMGP - logical, intent(in ) :: & - use_GP_jacobian ! Use RRTMGP LW Jacobian of upwelling to adjust the surface flux? - real(kind=kind_phys), intent(in ), dimension(im) :: & - skt ! Skin temperature - real(kind=kind_phys), intent(inout), dimension(im) :: & - sktp1r ! Skin temperature at previous timestep - real(kind=kind_phys), intent(in ), dimension(im,levs+1), optional :: & - fluxlwUP, & ! Upwelling LW flux (W/m2) - fluxlwUP_jac ! Jacobian of upwelling LW flux (W/m2/K) ! These arrays are only allocated if ldiag3d is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp @@ -211,7 +200,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl integer :: i, k real(kind=kind_phys) :: tem1, tem2, tem, hocp logical, dimension(im) :: invrsn - real(kind=kind_phys), dimension(im) :: tx1, tx2, dT + real(kind=kind_phys), dimension(im) :: tx1, tx2 real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys @@ -241,20 +230,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... when using RRTMGP w/ use_GP_jacobian, these adjustment factors are pre-computed ! --- ... and provided as inputs in this routine. - - if (use_GP_jacobian) then - ! Compute adjustment to the surface flux using Jacobian. - if(linit_mod) then - dT(:) = (sktp1r(:) - skt(:)) - adjsfculw(:) = fluxlwUP(:,1) + fluxlwUP_jac(:,1) * dT(:) - else - adjsfculw(:) = fluxlwUP(:,1) - linit_mod = .true. - endif - - ! Store surface temperature for next iteration - sktp1r(:) = skt(:) - else + if (frac_grid) then do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell @@ -292,7 +268,6 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl endif enddo endif - endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index b27884f9a..dba0567ce 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -785,51 +785,7 @@ type = real kind = kind_phys intent = in - optional = F -[use_GP_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in - optional = F -[skt] - standard_name = air_temperature_at_lowest_model_layer - long_name = air temperature at lowest model layer - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sktp1r] - standard_name = surface_skin_temperature_at_previous_time_step - long_name = surface skin temperature at previous time step - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fluxlwUP] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = T -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward - long_name = RRTMGP Jacobian upward longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = T + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 22eece516..3e4f3b615 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -179,6 +179,7 @@ subroutine dcyc2t3_run & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & & dry, icy, wet, & + & use_LW_jacobian, fluxlwUP, fluxlwUP_jac, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: & dtdt,dtdtc, & @@ -210,6 +211,7 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(im), intent(in) :: dry, icy, wet + logical, intent(in) :: use_LW_jacobian real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & & deltim, fhswr @@ -227,6 +229,9 @@ subroutine dcyc2t3_run & real(kind=kind_phys), dimension(im,levs), intent(in) :: swh, hlw & &, swhc, hlwc + real(kind=kind_phys), dimension(im,levs+1), intent(in) :: & + & fluxlwUP, & + & fluxlwUP_jac ! --- input/output: real(kind=kind_phys), dimension(im,levs), intent(inout) :: dtdt & @@ -303,21 +308,29 @@ subroutine dcyc2t3_run & !! - compute \a sfc upward LW flux from current \a sfc temperature. ! note: sfc emiss effect is not appied here, and will be dealt in other place - if (dry(i)) then - tem2 = tsfc_lnd(i) * tsfc_lnd(i) - adjsfculw_lnd(i) = sfcemis_lnd(i) * con_sbc * tem2 * tem2 - & + (one - sfcemis_lnd(i)) * adjsfcdlw(i) - endif - if (icy(i)) then - tem2 = tsfc_ice(i) * tsfc_ice(i) - adjsfculw_ice(i) = sfcemis_ice(i) * con_sbc * tem2 * tem2 - & + (one - sfcemis_ice(i)) * adjsfcdlw(i) - endif - if (wet(i)) then - tem2 = tsfc_wat(i) * tsfc_wat(i) - adjsfculw_wat(i) = sfcemis_wat(i) * con_sbc * tem2 * tem2 - & + (one - sfcemis_wat(i)) * adjsfcdlw(i) - endif + if (use_LW_Jacobian) then + ! Change in surface air-temperature since last radiation call. + tem1 = tsflw(i) - tf(i) + adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 + adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 + adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 + else + if (dry(i)) then + tem2 = tsfc_lnd(i) * tsfc_lnd(i) + adjsfculw_lnd(i) = sfcemis_lnd(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_lnd(i)) * adjsfcdlw(i) + endif + if (icy(i)) then + tem2 = tsfc_ice(i) * tsfc_ice(i) + adjsfculw_ice(i) = sfcemis_ice(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_ice(i)) * adjsfcdlw(i) + endif + if (wet(i)) then + tem2 = tsfc_wat(i) * tsfc_wat(i) + adjsfculw_wat(i) = sfcemis_wat(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_wat(i)) * adjsfcdlw(i) + endif + endif ! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: dry==',dry(i) ! &,' wet=',wet(i),' icy=',icy(i),' tsfc3=',tsfc3(i,:) ! &,' sfcemis=',sfcemis(i,:),' adjsfculw=',adjsfculw(i,:) diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 6fbc7f8b6..c36f63bd6 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -506,6 +506,32 @@ kind = kind_phys intent = out optional = F +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fluxlwUP] + standard_name = RRTMGP_lw_flux_profile_upward_allsky + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[fluxlwUP_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward + long_name = RRTMGP Jacobian upward longwave flux profile + units = W m-2 K-1 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index cf85aa7f2..f2dfb0694 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -63,15 +63,13 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, fluxlwUP_allsky, & ! All-sky flux (W/m2) fluxlwDOWN_allsky, & ! All-sky flux (W/m2) fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) - fluxlwDOWN_clrsky ! All-sky flux (W/m2) + fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) + fluxlwUP_jac, & ! Jacobian of upward LW flux (W/m2/K) + fluxlwDOWN_jac ! Jacobian of downward LW flux (W/m2/K) character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag - ! Outputs (optional) - real(kind_phys), dimension(ncol,nLev+1), intent(out), optional :: & - fluxlwUP_jac, & ! Jacobian of upward LW flux (W/m2/K) - fluxlwDOWN_jac ! Jacobian of downward LW flux (W/m2/K) + errflg ! CCPP error flag ! Local variables type(ty_fluxes_byband) :: & diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 443792edf..1d5300f5c 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -166,7 +166,7 @@ type = real kind = kind_phys intent = out - optional = T + optional = F [fluxlwDOWN_jac] standard_name = RRTMGP_jacobian_of_lw_flux_profile_downward long_name = RRTMGP Jacobian downward of longwave flux profile @@ -175,7 +175,7 @@ type = real kind = kind_phys intent = out - optional = T + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From d0174a32df95e5ad15037c4feead7c93bd6d34a4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Dec 2020 14:24:39 -0700 Subject: [PATCH 18/67] Use tsfc from lsm for dt in GP lw sfc flux adjustment. --- physics/dcyc2.f | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 3e4f3b615..ada372aa6 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -309,11 +309,19 @@ subroutine dcyc2t3_run & ! note: sfc emiss effect is not appied here, and will be dealt in other place if (use_LW_Jacobian) then - ! Change in surface air-temperature since last radiation call. - tem1 = tsflw(i) - tf(i) - adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 - adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 - adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * tem1 + ! F_adj = F_o + (dF/dT) * dT + if (dry(i)) then + adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsflw(i) - tsfc_lnd(i)) + endif + if (icy(i)) then + adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsflw(i) - tsfc_ice(i)) + endif + if (wet(i)) then + adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsflw(i) - tsfc_wat(i)) + endif else if (dry(i)) then tem2 = tsfc_lnd(i) * tsfc_lnd(i) From 17ea62b6d8aaa8af8c1df8d216673bdcc94fe93f Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Dec 2020 15:16:45 -0700 Subject: [PATCH 19/67] Compute GP LW adjustement in dcyc2, pass through GFS_suite_interstitial --- physics/GFS_suite_interstitial.F90 | 7 +++++-- physics/GFS_suite_interstitial.meta | 8 ++++++++ physics/dcyc2.f | 20 +++++--------------- physics/dcyc2.meta | 9 +++++++++ 4 files changed, 27 insertions(+), 17 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index c5d203457..89508ea17 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -163,7 +163,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, errmsg, errflg) + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, errmsg, errflg) implicit none @@ -184,6 +184,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat real(kind=kind_phys), intent( out), dimension(im) :: adjsfculw + + ! RRTMGP inputs + logical, intent(in ) :: use_LW_jacobian ! These arrays are only allocated if ldiag3d is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp @@ -230,7 +233,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... when using RRTMGP w/ use_GP_jacobian, these adjustment factors are pre-computed ! --- ... and provided as inputs in this routine. - + if (.not. use_LW_jacobian) if (frac_grid) then do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index dba0567ce..c3bdbc611 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -637,6 +637,14 @@ kind = kind_phys intent = in optional = F +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F [dlwsfc] standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep long_name = cumulative surface downwelling LW flux multiplied by timestep diff --git a/physics/dcyc2.f b/physics/dcyc2.f index ada372aa6..6061de509 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -184,7 +184,7 @@ subroutine dcyc2t3_run & ! --- input/output: & dtdt,dtdtc, & ! --- outputs: - & adjsfcdsw,adjsfcnsw,adjsfcdlw, & + & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw, & & adjsfculw_lnd,adjsfculw_ice,adjsfculw_wat,xmu,xcosz, & & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd, & @@ -244,7 +244,7 @@ subroutine dcyc2t3_run & & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd real(kind=kind_phys), dimension(im), intent(out) :: & - & adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat + & adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat, adjsfculw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -309,19 +309,9 @@ subroutine dcyc2t3_run & ! note: sfc emiss effect is not appied here, and will be dealt in other place if (use_LW_Jacobian) then - ! F_adj = F_o + (dF/dT) * dT - if (dry(i)) then - adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsflw(i) - tsfc_lnd(i)) - endif - if (icy(i)) then - adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsflw(i) - tsfc_ice(i)) - endif - if (wet(i)) then - adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsflw(i) - tsfc_wat(i)) - endif + ! F_adj = F_o + (dF/dT) * dT + adjsfculw(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsflw(i) - tf(i)) else if (dry(i)) then tem2 = tsfc_lnd(i) * tsfc_lnd(i) diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index c36f63bd6..fd748edfd 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -389,6 +389,15 @@ kind = kind_phys intent = out optional = F +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F [adjsfculw_lnd] standard_name = surface_upwelling_longwave_flux_over_land_interstitial long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) From 95d271e9937b6407135f343c6a4b019fcc4973b0 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Dec 2020 15:18:57 -0700 Subject: [PATCH 20/67] Omission from previous commit --- physics/GFS_suite_interstitial.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 89508ea17..1086e444b 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -233,7 +233,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... when using RRTMGP w/ use_GP_jacobian, these adjustment factors are pre-computed ! --- ... and provided as inputs in this routine. - if (.not. use_LW_jacobian) + if (.not. use_LW_jacobian) then if (frac_grid) then do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell @@ -271,6 +271,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl endif enddo endif + endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf From 9354fd2fd4290bbd326a1e54bb12abd1f7d6ea22 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 4 Dec 2020 16:46:16 -0700 Subject: [PATCH 21/67] add output of the new kinematic surface fluxes modified by GFS_surface_generic to the gmtb_scm_spec_sfc_flux scheme (fixes specified surface flux cases for SCM) --- physics/gmtb_scm_sfc_flux_spec.F90 | 24 ++++++++++++--- physics/gmtb_scm_sfc_flux_spec.meta | 48 +++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 5 deletions(-) diff --git a/physics/gmtb_scm_sfc_flux_spec.F90 b/physics/gmtb_scm_sfc_flux_spec.F90 index d77e42000..22730f9f2 100644 --- a/physics/gmtb_scm_sfc_flux_spec.F90 +++ b/physics/gmtb_scm_sfc_flux_spec.F90 @@ -15,7 +15,18 @@ module gmtb_scm_sfc_flux_spec CONTAINS !******************************************************************************************* - subroutine gmtb_scm_sfc_flux_spec_init() + subroutine gmtb_scm_sfc_flux_spec_init(lheatstrg, errmsg, errflg) + + logical, intent(in) :: lheatstrg + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + if (lheatstrg) then + errmsg = 'Using specified surface fluxes is not compatible with canopy heat storage (lheatstrg) being true. Stopping.' + errflg = 1 + return + end if end subroutine gmtb_scm_sfc_flux_spec_init subroutine gmtb_scm_sfc_flux_spec_finalize() @@ -38,16 +49,17 @@ end subroutine gmtb_scm_sfc_flux_spec_finalize !! -# Calculate the surface drag coefficient for heat and moisture. !! -# Calculate the u and v wind at 10m. subroutine gmtb_scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & - exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, sh_flux, lh_flux, u_star, sfc_stress, cm, ch, & + exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, sh_flux, lh_flux, sh_flux_chs, lh_flux_chs, u_star, sfc_stress, cm, ch, & fm, fh, rb, u10m, v10m, wind1, qss, t2m, q2m, errmsg, errflg) use machine, only: kind_phys - + real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:) real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & - cm(:), ch(:), fm(:), fh(:), rb(:), u10m(:), v10m(:), wind1(:), qss(:), t2m(:), q2m(:) + cm(:), ch(:), fm(:), fh(:), rb(:), u10m(:), v10m(:), wind1(:), qss(:), t2m(:), q2m(:), & + sh_flux_chs(:), lh_flux_chs(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -60,12 +72,14 @@ subroutine gmtb_scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + ! !--- set control properties (including namelist read) !calculate u_star from wind profiles (need roughness length, and wind and height at lowest model level) do i=1, size(z1) sh_flux(i) = spec_sh_flux(i) lh_flux(i) = spec_lh_flux(i) + sh_flux_chs(i) = sh_flux(i) + lh_flux_chs(i) = lh_flux(i) roughness_length_m = 0.01*roughness_length(i) diff --git a/physics/gmtb_scm_sfc_flux_spec.meta b/physics/gmtb_scm_sfc_flux_spec.meta index 71ddff22a..1e004b7f9 100644 --- a/physics/gmtb_scm_sfc_flux_spec.meta +++ b/physics/gmtb_scm_sfc_flux_spec.meta @@ -4,6 +4,36 @@ dependencies = machine.F ######################################################################## +[ccpp-arg-table] + name = gmtb_scm_sfc_flux_spec_init + type = scheme +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + 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 = gmtb_scm_sfc_flux_spec_run type = scheme @@ -178,6 +208,24 @@ kind = kind_phys intent = out optional = F +[sh_flux_chs] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness + long_name = kinematic surface upward sensible heat flux reduced by surface roughness + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[lh_flux_chs] + standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + long_name = kinematic surface upward latent heat flux reduced by surface roughness + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F [u_star] standard_name = surface_friction_velocity long_name = boundary layer parameter From a6372010f345caa343e0d484d70dfd6b6c91b1c5 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Dec 2020 10:37:59 -0700 Subject: [PATCH 22/67] Save temperatures from LSM at radiaiton time-steps for LW adjustment. --- physics/GFS_suite_interstitial.F90 | 9 +----- physics/GFS_suite_interstitial.meta | 10 +------ physics/dcyc2.f | 35 ++++++++++++++++++----- physics/dcyc2.meta | 44 +++++++++++++++++++++++------ 4 files changed, 65 insertions(+), 33 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 1086e444b..b7ea2f792 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -163,7 +163,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, errmsg, errflg) + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, errmsg, errflg) implicit none @@ -184,9 +184,6 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat real(kind=kind_phys), intent( out), dimension(im) :: adjsfculw - - ! RRTMGP inputs - logical, intent(in ) :: use_LW_jacobian ! These arrays are only allocated if ldiag3d is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp @@ -231,9 +228,6 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... sfc lw fluxes used by atmospheric model are saved for output -! --- ... when using RRTMGP w/ use_GP_jacobian, these adjustment factors are pre-computed -! --- ... and provided as inputs in this routine. - if (.not. use_LW_jacobian) then if (frac_grid) then do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell @@ -271,7 +265,6 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl endif enddo endif - endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index c3bdbc611..0c055d17c 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -636,15 +636,7 @@ type = real kind = kind_phys intent = in - optional = F -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in - optional = F + optional = F [dlwsfc] standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep long_name = cumulative surface downwelling LW flux multiplied by timestep diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 6061de509..fe39a187f 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -179,12 +179,13 @@ subroutine dcyc2t3_run & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & & dry, icy, wet, & - & use_LW_jacobian, fluxlwUP, fluxlwUP_jac, & + & use_LW_jacobian, doLWrad, fluxlwUP, fluxlwUP_jac, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: + & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt, & & dtdt,dtdtc, & ! --- outputs: - & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw, & + & adjsfcdsw,adjsfcnsw,adjsfcdlw, & & adjsfculw_lnd,adjsfculw_ice,adjsfculw_wat,xmu,xcosz, & & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd, & @@ -211,7 +212,7 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(im), intent(in) :: dry, icy, wet - logical, intent(in) :: use_LW_jacobian + logical, intent(in) :: use_LW_jacobian, doLWrad real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & & deltim, fhswr @@ -229,6 +230,9 @@ subroutine dcyc2t3_run & real(kind=kind_phys), dimension(im,levs), intent(in) :: swh, hlw & &, swhc, hlwc + + real(kind=kind_phys), dimension(im), intent(inout) :: & + & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt real(kind=kind_phys), dimension(im,levs+1), intent(in) :: & & fluxlwUP, & & fluxlwUP_jac @@ -244,7 +248,7 @@ subroutine dcyc2t3_run & & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd real(kind=kind_phys), dimension(im), intent(out) :: & - & adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat, adjsfculw + & adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -309,9 +313,26 @@ subroutine dcyc2t3_run & ! note: sfc emiss effect is not appied here, and will be dealt in other place if (use_LW_Jacobian) then - ! F_adj = F_o + (dF/dT) * dT - adjsfculw(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsflw(i) - tf(i)) + ! Update temperature for LW flux adjustment at radiation calls. + if (doLWrad) then + tsfc_lnd_radt(i) = tsfc_lnd(i) + tsfc_wat_radt(i) = tsfc_wat(i) + tsfc_ice_radt(i) = tsfc_ice(i) + endif + + ! F_adj = F_o + (dF/dT) * dT + if (dry(i)) then + adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsfc_lnd_radt(i) - tsfc_lnd(i)) + endif + if (icy(i)) then + adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsfc_ice_radt(i) - tsfc_ice(i)) + endif + if (wet(i)) then + adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * + & (tsfc_wat_radt(i) - tsfc_wat(i)) + endif else if (dry(i)) then tem2 = tsfc_lnd(i) * tsfc_lnd(i) diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index fd748edfd..8ccf5d9d1 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -106,6 +106,33 @@ kind = kind_phys intent = in optional = F +[tsfc_lnd_radt] + standard_name = surface_skin_temperature_over_land_interstitial_at_radiation_timestep + long_name = surface skin temperature over land at first call to radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_wat_radt] + standard_name = surface_skin_temperature_over_ocean_interstitial_at_radiation_timestep + long_name = surface skin temperature over ocean at first call to radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_ice_radt] + standard_name = surface_skin_temperature_over_ice_interstitial_at_radiation_timestep + long_name = surface skin temperature over ice at first call to radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [tf] standard_name = air_temperature_at_lowest_model_layer long_name = air temperature at lowest model layer @@ -389,15 +416,6 @@ kind = kind_phys intent = out optional = F -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F [adjsfculw_lnd] standard_name = surface_upwelling_longwave_flux_over_land_interstitial long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) @@ -523,6 +541,14 @@ type = logical intent = in optional = F +[doLWrad] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F [fluxlwUP] standard_name = RRTMGP_lw_flux_profile_upward_allsky long_name = RRTMGP upward longwave all-sky flux profile From dc13504c6347eac639ba74f7612c091918df0bbb Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Dec 2020 21:06:38 +0000 Subject: [PATCH 23/67] Some reorganization. --- physics/GFS_suite_interstitial.F90 | 75 ++++++++++++++++----------- physics/dcyc2.f | 83 ++++++++++++++++++------------ 2 files changed, 96 insertions(+), 62 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index b7ea2f792..c8f962886 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -150,9 +150,17 @@ module GFS_suite_interstitial_2 contains subroutine GFS_suite_interstitial_2_init () + open(97,file='dump97.txt',status='unknown') + open(98,file='dump98.txt',status='unknown') + open(99,file='dump99.txt',status='unknown') + open(100,file='dump100.txt',status='unknown') end subroutine GFS_suite_interstitial_2_init subroutine GFS_suite_interstitial_2_finalize() + close(97) + close(98) + close(99) + close(100) end subroutine GFS_suite_interstitial_2_finalize #if 0 !> \section arg_table_GFS_suite_interstitial_2_run Argument Table @@ -228,43 +236,52 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... sfc lw fluxes used by atmospheric model are saved for output - if (frac_grid) then - do i=1,im + if (frac_grid) then + do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) endif - enddo - else - do i=1,im + enddo + else + do i=1,im if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) + adjsfculw(i) = adjsfculw_lnd(i) elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif - else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = adjsfculw_ice(i) - endif - endif + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif + else + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif + endif else ! all water - adjsfculw(i) = adjsfculw_wat(i) + adjsfculw(i) = adjsfculw_wat(i) endif - enddo - endif + enddo + endif + + write(97,*) "#####" + write(97,*) adjsfculw + write(98,*) "#####" + write(98,*) adjsfculw_lnd + write(99,*) "#####" + write(99,*) adjsfculw_wat + write(100,*) "#####" + write(100,*) adjsfculw_ice do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf diff --git a/physics/dcyc2.f b/physics/dcyc2.f index fe39a187f..d5ad9759f 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -17,9 +17,17 @@ module dcyc2t3 contains subroutine dcyc2t3_init() + open(93,file='dumpLND.txt',status='unknown') + open(94,file='dumpWAT.txt',status='unknown') + open(95,file='dumpICE.txt',status='unknown') + open(96,file='dumpFLUX.txt',status='unknown') end subroutine dcyc2t3_init subroutine dcyc2t3_finalize() + close(93) + close(94) + close(95) + close(96) end subroutine dcyc2t3_finalize ! ===================================================================== ! @@ -232,10 +240,10 @@ subroutine dcyc2t3_run & &, swhc, hlwc real(kind=kind_phys), dimension(im), intent(inout) :: & - & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt + & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt real(kind=kind_phys), dimension(im,levs+1), intent(in) :: & - & fluxlwUP, & - & fluxlwUP_jac + & fluxlwUP, & + & fluxlwUP_jac ! --- input/output: real(kind=kind_phys), dimension(im,levs), intent(inout) :: dtdt & @@ -300,40 +308,49 @@ subroutine dcyc2t3_run & enddo endif ! - do i = 1, im + ! Update temperature for LW flux adjustment at radiation calls. + if (doLWrad) then + tsfc_lnd_radt(1:im) = tsfc_lnd(1:im) + tsfc_wat_radt(1:im) = tsfc_wat(1:im) + tsfc_ice_radt(1:im) = tsfc_ice(1:im) + endif + + write(93,*) "#######",doLWrad + write(93,*) tsfc_lnd + write(93,*) "-" + write(93,*) tsfc_lnd_radt + write(94,*) "#######" + write(94,*) tsfc_wat - tsfc_wat_radt + write(95,*) "#######" + write(95,*) tsfc_ice - tsfc_ice_radt + write(96,*) "#######" + write(96,*) fluxlwUP(:,1) + write(96,*) "-" + write(96,*) fluxlwUP_jac(:,1) + + do i = 1, im !> - LW time-step adjustment: + if (use_LW_Jacobian) then + ! F_adj = F_o + (dF/dT) * dT + if (dry(i)) then + adjsfculw_lnd(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * + & (tsfc_lnd_radt(i) - tsfc_lnd(i)) + endif + if (icy(i)) then + adjsfculw_ice(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * + & (tsfc_ice_radt(i) - tsfc_ice(i)) + endif + if (wet(i)) then + adjsfculw_wat(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * + & (tsfc_wat_radt(i) - tsfc_wat(i)) + endif + else !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. !! compute 4th power of the ratio of \c tf in the lowest model layer over the mean value \c tsflw. - tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 - adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 - -!! - compute \a sfc upward LW flux from current \a sfc temperature. -! note: sfc emiss effect is not appied here, and will be dealt in other place - - if (use_LW_Jacobian) then - ! Update temperature for LW flux adjustment at radiation calls. - if (doLWrad) then - tsfc_lnd_radt(i) = tsfc_lnd(i) - tsfc_wat_radt(i) = tsfc_wat(i) - tsfc_ice_radt(i) = tsfc_ice(i) - endif - - ! F_adj = F_o + (dF/dT) * dT - if (dry(i)) then - adjsfculw_lnd(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsfc_lnd_radt(i) - tsfc_lnd(i)) - endif - if (icy(i)) then - adjsfculw_ice(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsfc_ice_radt(i) - tsfc_ice(i)) - endif - if (wet(i)) then - adjsfculw_wat(i) = fluxlwUP(im,1) + fluxlwUP_jac(im,1) * - & (tsfc_wat_radt(i) - tsfc_wat(i)) - endif - else + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 if (dry(i)) then tem2 = tsfc_lnd(i) * tsfc_lnd(i) adjsfculw_lnd(i) = sfcemis_lnd(i) * con_sbc * tem2 * tem2 From 64abfa90afc9e1a8896bfa66583cac5592315d62 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Dec 2020 14:30:17 -0700 Subject: [PATCH 24/67] Intent(out) -> intent(inout) --- physics/rrtmgp_lw_rte.F90 | 2 +- physics/rrtmgp_lw_rte.meta | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index f2dfb0694..1c86db5f1 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -59,7 +59,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, lw_optical_props_clouds ! RRTMGP DDT: longwave cloud radiative properties ! Outputs - real(kind_phys), dimension(ncol,nLev+1), intent(out) :: & + real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & fluxlwUP_allsky, & ! All-sky flux (W/m2) fluxlwDOWN_allsky, & ! All-sky flux (W/m2) fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 1d5300f5c..d249c77d6 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -129,7 +129,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [fluxlwDOWN_allsky] standard_name = RRTMGP_lw_flux_profile_downward_allsky @@ -138,7 +138,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [fluxlwUP_clrsky] standard_name = RRTMGP_lw_flux_profile_upward_clrsky @@ -147,7 +147,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [fluxlwDOWN_clrsky] standard_name = RRTMGP_lw_flux_profile_downward_clrsky @@ -156,7 +156,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [fluxlwUP_jac] standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward @@ -165,7 +165,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [fluxlwDOWN_jac] standard_name = RRTMGP_jacobian_of_lw_flux_profile_downward @@ -174,7 +174,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [errmsg] standard_name = ccpp_error_message From 9a48b33b91ebcd33bd818c81c8d3b6b1a4d3e1e9 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Dec 2020 15:53:07 -0700 Subject: [PATCH 25/67] Use combined land/sea/ice surface temperature for LW adjustment of surface flux. --- physics/dcyc2.f | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index d5ad9759f..62b9f554b 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -311,10 +311,14 @@ subroutine dcyc2t3_run & ! Update temperature for LW flux adjustment at radiation calls. if (doLWrad) then - tsfc_lnd_radt(1:im) = tsfc_lnd(1:im) - tsfc_wat_radt(1:im) = tsfc_wat(1:im) - tsfc_ice_radt(1:im) = tsfc_ice(1:im) + do i = 1, im + tsfc_lnd_radt(i) = minval([tsfc_lnd(i),tsfc_wat(i), + & tsfc_ice(i)]) + enddo + !tsfc_wat_radt(1:im) = tsfc_wat(1:im) + !tsfc_ice_radt(1:im) = tsfc_ice(1:im) endif + write(93,*) "#######",doLWrad write(93,*) tsfc_lnd @@ -339,11 +343,11 @@ subroutine dcyc2t3_run & endif if (icy(i)) then adjsfculw_ice(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * - & (tsfc_ice_radt(i) - tsfc_ice(i)) + & (tsfc_lnd_radt(i) - tsfc_ice(i)) endif if (wet(i)) then adjsfculw_wat(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * - & (tsfc_wat_radt(i) - tsfc_wat(i)) + & (tsfc_lnd_radt(i) - tsfc_wat(i)) endif else !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. From ae1430921506c942509a3ebba9cd0785a3de316a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Dec 2020 16:24:32 -0700 Subject: [PATCH 26/67] Added print statements for diag. --- physics/GFS_suite_interstitial.F90 | 20 ++++--------------- physics/dcyc2.f | 31 +++++++----------------------- 2 files changed, 11 insertions(+), 40 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index c8f962886..898f6d454 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -150,17 +150,9 @@ module GFS_suite_interstitial_2 contains subroutine GFS_suite_interstitial_2_init () - open(97,file='dump97.txt',status='unknown') - open(98,file='dump98.txt',status='unknown') - open(99,file='dump99.txt',status='unknown') - open(100,file='dump100.txt',status='unknown') end subroutine GFS_suite_interstitial_2_init subroutine GFS_suite_interstitial_2_finalize() - close(97) - close(98) - close(99) - close(100) end subroutine GFS_suite_interstitial_2_finalize #if 0 !> \section arg_table_GFS_suite_interstitial_2_run Argument Table @@ -274,14 +266,10 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl enddo endif - write(97,*) "#####" - write(97,*) adjsfculw - write(98,*) "#####" - write(98,*) adjsfculw_lnd - write(99,*) "#####" - write(99,*) adjsfculw_wat - write(100,*) "#####" - write(100,*) adjsfculw_ice + print*, 'adjsfculw: ',adjsfculw + print*, 'adjsfculw_lnd: ',adjsfculw_lnd + print*, 'adjsfculw_wat: ',adjsfculw_wat + print*, 'adjsfculw_ice: ',adjsfculw_ice do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 62b9f554b..6e1197113 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -17,17 +17,9 @@ module dcyc2t3 contains subroutine dcyc2t3_init() - open(93,file='dumpLND.txt',status='unknown') - open(94,file='dumpWAT.txt',status='unknown') - open(95,file='dumpICE.txt',status='unknown') - open(96,file='dumpFLUX.txt',status='unknown') end subroutine dcyc2t3_init subroutine dcyc2t3_finalize() - close(93) - close(94) - close(95) - close(96) end subroutine dcyc2t3_finalize ! ===================================================================== ! @@ -315,23 +307,14 @@ subroutine dcyc2t3_run & tsfc_lnd_radt(i) = minval([tsfc_lnd(i),tsfc_wat(i), & tsfc_ice(i)]) enddo - !tsfc_wat_radt(1:im) = tsfc_wat(1:im) - !tsfc_ice_radt(1:im) = tsfc_ice(1:im) endif - - - write(93,*) "#######",doLWrad - write(93,*) tsfc_lnd - write(93,*) "-" - write(93,*) tsfc_lnd_radt - write(94,*) "#######" - write(94,*) tsfc_wat - tsfc_wat_radt - write(95,*) "#######" - write(95,*) tsfc_ice - tsfc_ice_radt - write(96,*) "#######" - write(96,*) fluxlwUP(:,1) - write(96,*) "-" - write(96,*) fluxlwUP_jac(:,1) + + print*, 'tsfc_lnd_radt: ',tsfc_lnd + print*, 'tsfc_lnd: ',tsfc_lnd_radt + print*, 'tsfc_wat: ',tsfc_wat + print*, 'tsfc_ice: ',tsfc_ice + print*, 'fluxlwUP(:,1): ',fluxlwUP(:,1) + print*, 'fluxlwUP_jac(:,1): ',fluxlwUP_jac(:,1) do i = 1, im !> - LW time-step adjustment: From 250de74fce42c6ecda654f4d47508d9ffa3c5335 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 8 Dec 2020 21:45:23 +0000 Subject: [PATCH 27/67] Cleanup of GP LW flux adjustment using Jacobian of surface upwelling. --- physics/GFS_rrtmgp_lw_post.F90 | 14 +++--- physics/GFS_rrtmgp_lw_post.meta | 9 ++++ physics/GFS_suite_interstitial.F90 | 14 +++--- physics/GFS_suite_interstitial.meta | 10 ++++- physics/dcyc2.f | 59 ++++++------------------ physics/dcyc2.meta | 70 +++++++++-------------------- physics/rrtmgp_lw_rte.F90 | 22 ++++++--- physics/rrtmgp_lw_rte.meta | 17 ++----- 8 files changed, 87 insertions(+), 128 deletions(-) diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index e6f6a59a5..e2dbd17fa 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -27,7 +27,7 @@ end subroutine GFS_rrtmgp_lw_post_init subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag, fhlwr, & p_lev, t_lay, tsfa, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & fluxlwDOWN_clrsky, raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, & - sfcdlw, sfcflw, tsflw, htrlw, topflw, flxprf_lw, htrlwc, errmsg, errflg) + sfcdlw, sfculw, sfcflw, tsflw, htrlw, topflw, flxprf_lw, htrlwc, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -65,11 +65,12 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(inout) :: & - sfcdlw, & ! Total sky sfc downward lw flux (W/m2) - tsflw ! surface air temp during lw calculation (K) - type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc + real(kind_phys), dimension(nCol), intent(inout) :: & + sfcdlw, & ! Total sky sfc downward lw flux (W/m2) + sfculw, & ! Total sky sfc upward lw flux (W/m2) + tsflw ! surface air temp during lw calculation (K) + type(sfcflw_type), dimension(nCol), intent(inout) :: & + sfcflw ! LW radiation fluxes at sfc real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw ! LW all-sky heating rate type(topflw_type), dimension(nCol), intent(out) :: & @@ -160,6 +161,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! Radiation fluxes for other physics processes sfcdlw(:) = sfcflw(:)%dnfxc + sfculw(:) = sfcflw(:)%upfxc ! ####################################################################################### ! Save LW diagnostics diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta index a87b6adcb..72a82421e 100644 --- a/physics/GFS_rrtmgp_lw_post.meta +++ b/physics/GFS_rrtmgp_lw_post.meta @@ -198,6 +198,15 @@ kind = kind_phys intent = inout optional = F +[sfculw] + standard_name = surface_upwelling_longwave_flux_on_radiation_time_step + long_name = total sky sfc upward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [sfcflw] standard_name = lw_fluxes_sfc long_name = lw radiation fluxes at sfc diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 898f6d454..62efa00d5 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -163,14 +163,14 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, errmsg, errflg) + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, errmsg, errflg) implicit none ! interface variables integer, intent(in ) :: im, levs, imfshalcnv logical, intent(in ) :: lssav, ldiag3d, lsidea, cplflx, shal_cnv - logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid + logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian real(kind=kind_phys), intent(in ) :: dtf, cp, hvap logical, intent(in ), dimension(im) :: flag_cice @@ -183,7 +183,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl integer, intent(inout), dimension(im) :: kinver real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat - real(kind=kind_phys), intent( out), dimension(im) :: adjsfculw + real(kind=kind_phys), intent(inout), dimension(im) :: adjsfculw ! These arrays are only allocated if ldiag3d is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp @@ -227,7 +227,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl enddo ! --- ... sfc lw fluxes used by atmospheric model are saved for output - + if (.not. use_LW_jacobian) then if (frac_grid) then do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell @@ -265,11 +265,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl endif enddo endif - - print*, 'adjsfculw: ',adjsfculw - print*, 'adjsfculw_lnd: ',adjsfculw_lnd - print*, 'adjsfculw_wat: ',adjsfculw_wat - print*, 'adjsfculw_ice: ',adjsfculw_ice + endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 0c055d17c..fdf1716f1 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -601,6 +601,14 @@ kind = kind_phys intent = inout optional = F +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F [adjsfculw] standard_name = surface_upwelling_longwave_flux long_name = surface upwelling longwave flux at current time @@ -608,7 +616,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [adjsfculw_lnd] standard_name = surface_upwelling_longwave_flux_over_land_interstitial diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 6e1197113..389496d07 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -42,7 +42,7 @@ end subroutine dcyc2t3_finalize ! ( solhr,slag,sdec,cdec,sinlat,coslat, ! ! xlon,coszen,tsfc_lnd,tsfc_ice,tsfc_wat, ! ! tf,tsflw,sfcemis_lnd,sfcemis_ice,sfcemis_wat, ! -! sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, ! +! sfcdsw,sfcnsw,sfcdlw,sfculw,swh,swhc,hlw,hlwc, ! ! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, ! ! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, ! ! im, levs, deltim, fhswr, ! @@ -50,7 +50,7 @@ end subroutine dcyc2t3_finalize ! input/output: ! ! dtdt,dtdtc, ! ! outputs: ! -! adjsfcdsw,adjsfcnsw,adjsfcdlw, ! +! adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw, ! ! adjsfculw_lnd,adjsfculw_ice,adjsfculw_wat,xmu,xcosz, ! ! adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, ! ! adjdnnbmd,adjdnndfd,adjdnvbmd,adjdnvdfd) ! @@ -76,6 +76,7 @@ end subroutine dcyc2t3_finalize ! sfcdsw (im) - real, total sky sfc downward sw flux ( w/m**2 ) ! ! sfcnsw (im) - real, total sky sfc net sw into ground (w/m**2) ! ! sfcdlw (im) - real, total sky sfc downward lw flux ( w/m**2 ) ! +! sfculw (im) - real, total sky sfc upward lw flux ( w/m**2 ) ! ! swh(im,levs) - real, total sky sw heating rates ( k/s ) ! ! swhc(im,levs) - real, clear sky sw heating rates ( k/s ) ! ! hlw(im,levs) - real, total sky lw heating rates ( k/s ) ! @@ -179,13 +180,12 @@ subroutine dcyc2t3_run & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & & dry, icy, wet, & - & use_LW_jacobian, doLWrad, fluxlwUP, fluxlwUP_jac, & + & use_LW_jacobian, sfculw, sfculw_jac, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: - & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt, & & dtdt,dtdtc, & ! --- outputs: - & adjsfcdsw,adjsfcnsw,adjsfcdlw, & + & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw, & & adjsfculw_lnd,adjsfculw_ice,adjsfculw_wat,xmu,xcosz, & & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd, & @@ -212,13 +212,13 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(im), intent(in) :: dry, icy, wet - logical, intent(in) :: use_LW_jacobian, doLWrad + logical, intent(in) :: use_LW_jacobian real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & & deltim, fhswr real(kind=kind_phys), dimension(im), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & - & sfcdsw, sfcnsw + & sfcdsw, sfcnsw, sfculw, sfculw_jac real(kind=kind_phys), dimension(im), intent(in) :: & & tsfc_lnd, tsfc_ice, tsfc_wat, & @@ -231,19 +231,13 @@ subroutine dcyc2t3_run & real(kind=kind_phys), dimension(im,levs), intent(in) :: swh, hlw & &, swhc, hlwc - real(kind=kind_phys), dimension(im), intent(inout) :: & - & tsfc_lnd_radt , tsfc_ice_radt , tsfc_wat_radt - real(kind=kind_phys), dimension(im,levs+1), intent(in) :: & - & fluxlwUP, & - & fluxlwUP_jac - ! --- input/output: real(kind=kind_phys), dimension(im,levs), intent(inout) :: dtdt & &, dtdtc ! --- outputs: real(kind=kind_phys), dimension(im), intent(out) :: & - & adjsfcdsw, adjsfcnsw, adjsfcdlw, xmu, xcosz, & + & adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd @@ -256,7 +250,7 @@ subroutine dcyc2t3_run & ! --- locals: integer :: i, k, nstp, nstl, it, istsun(im) real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & - & rstl, solang + & rstl, solang, dT ! !===> ... begin here ! @@ -301,43 +295,18 @@ subroutine dcyc2t3_run & endif ! - ! Update temperature for LW flux adjustment at radiation calls. - if (doLWrad) then - do i = 1, im - tsfc_lnd_radt(i) = minval([tsfc_lnd(i),tsfc_wat(i), - & tsfc_ice(i)]) - enddo - endif - - print*, 'tsfc_lnd_radt: ',tsfc_lnd - print*, 'tsfc_lnd: ',tsfc_lnd_radt - print*, 'tsfc_wat: ',tsfc_wat - print*, 'tsfc_ice: ',tsfc_ice - print*, 'fluxlwUP(:,1): ',fluxlwUP(:,1) - print*, 'fluxlwUP_jac(:,1): ',fluxlwUP_jac(:,1) - do i = 1, im + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !> - LW time-step adjustment: if (use_LW_Jacobian) then ! F_adj = F_o + (dF/dT) * dT - if (dry(i)) then - adjsfculw_lnd(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * - & (tsfc_lnd_radt(i) - tsfc_lnd(i)) - endif - if (icy(i)) then - adjsfculw_ice(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * - & (tsfc_lnd_radt(i) - tsfc_ice(i)) - endif - if (wet(i)) then - adjsfculw_wat(i) = fluxlwUP(i,1) + fluxlwUP_jac(i,1) * - & (tsfc_lnd_radt(i) - tsfc_wat(i)) - endif + dT = tf(i) - tsflw(i) + adjsfculw(i) = sfculw(i) + sfculw_jac(i) * dT else !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. !! compute 4th power of the ratio of \c tf in the lowest model layer over the mean value \c tsflw. - tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 - adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 if (dry(i)) then tem2 = tsfc_lnd(i) * tsfc_lnd(i) adjsfculw_lnd(i) = sfcemis_lnd(i) * con_sbc * tem2 * tem2 diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 8ccf5d9d1..efba0a5f5 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -105,33 +105,6 @@ type = real kind = kind_phys intent = in - optional = F -[tsfc_lnd_radt] - standard_name = surface_skin_temperature_over_land_interstitial_at_radiation_timestep - long_name = surface skin temperature over land at first call to radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_wat_radt] - standard_name = surface_skin_temperature_over_ocean_interstitial_at_radiation_timestep - long_name = surface skin temperature over ocean at first call to radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_ice_radt] - standard_name = surface_skin_temperature_over_ice_interstitial_at_radiation_timestep - long_name = surface skin temperature over ice at first call to radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout optional = F [tf] standard_name = air_temperature_at_lowest_model_layer @@ -205,6 +178,15 @@ kind = kind_phys intent = in optional = F +[sfculw] + standard_name = surface_upwelling_longwave_flux_on_radiation_time_step + long_name = total sky sfc upward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [swh] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step long_name = total sky shortwave heating rate on radiation time step @@ -443,6 +425,15 @@ kind = kind_phys intent = out optional = F +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F [xmu] standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes long_name = zenith angle temporal adjustment factor for shortwave fluxes @@ -541,28 +532,11 @@ type = logical intent = in optional = F -[doLWrad] - standard_name = flag_to_calc_lw - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in - optional = F -[fluxlwUP] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward - long_name = RRTMGP Jacobian upward longwave flux profile +[sfculw_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_upward_at_surface + long_name = RRTMGP Jacobian upward longwave flux at surface units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index 1c86db5f1..321214a02 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -31,8 +31,7 @@ end subroutine rrtmgp_lw_rte_init subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & nLev, p_lev, lw_gas_props, sfc_emiss_byband, sources, lw_optical_props_clrsky, & lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwDOWN_jac,& - errmsg, errflg) + fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, sfculw_jac, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -59,13 +58,13 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, lw_optical_props_clouds ! RRTMGP DDT: longwave cloud radiative properties ! Outputs + real(kind_phys), dimension(ncol), intent(inout) :: & + sfculw_jac ! Jacobian of upwelling LW surface radiation (W/m2/K) real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & fluxlwUP_allsky, & ! All-sky flux (W/m2) fluxlwDOWN_allsky, & ! All-sky flux (W/m2) fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) - fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) - fluxlwUP_jac, & ! Jacobian of upward LW flux (W/m2/K) - fluxlwDOWN_jac ! Jacobian of downward LW flux (W/m2/K) + fluxlwDOWN_clrsky ! All-sky flux (W/m2) character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & @@ -76,8 +75,10 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, flux_allsky, flux_clrsky real(kind_phys), dimension(ncol,nLev+1,lw_gas_props%get_nband()),target :: & fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky + real(kind_phys), dimension(nCol,nLev+1) :: fluxlwUP_jac,fluxlwDOWN_jac logical :: & top_at_1 + integer :: iSFC, iTOA ! Initialize CCPP error handling variables errmsg = '' @@ -87,7 +88,14 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, ! Vertical ordering? top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) - + if (top_at_1) then + iSFC = nLev+1 + iTOA = 1 + else + iSFC = 1 + iTOA = nLev+1 + endif + ! Initialize RRTMGP DDT containing 2D(3D) fluxes flux_allsky%bnd_flux_up => fluxLW_up_allsky flux_allsky%bnd_flux_dn => fluxLW_dn_allsky @@ -140,6 +148,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac, & ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) flux_dn_Jac = fluxlwDOWN_jac)) ! OUT - surface temperature flux (downward) Jacobian (W/m2/K) + sfculw_jac = fluxlwUP_jac(:,iSFC) else call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clouds, & ! IN - optical-properties @@ -166,6 +175,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac, & ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) flux_dn_Jac = fluxlwDOWN_jac)) ! OUT - surface temperature flux (downward) Jacobian (W/m2/K) + sfculw_jac = fluxlwUP_jac(:,iSFC) else call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index d249c77d6..d295fa511 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -158,20 +158,11 @@ kind = kind_phys intent = inout optional = F -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward - long_name = RRTMGP Jacobian upward longwave flux profile +[sfculw_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_upward_at_surface + long_name = RRTMGP Jacobian upward longwave flux at surface units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = inout - optional = F -[fluxlwDOWN_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_downward - long_name = RRTMGP Jacobian downward of longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout From 196603cb1c87e9d4259a70beb9e0edbd044a39f0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 10 Dec 2020 12:59:50 -0700 Subject: [PATCH 28/67] From @@yangfanglin: add missing tsfc(i) = tsfc_ice(i) to reproduce GFS v16 behavior --- physics/GFS_surface_composites.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 6cbf35f03..92367ef4b 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -571,6 +571,7 @@ subroutine GFS_surface_composites_post_run ( snowd(i) = snowd_ice(i) !tprcp(i) = cice(i)*tprcp_ice(i) + (one-cice(i))*tprcp_wat(i) qss(i) = qss_ice(i) + tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) From 186832a4b33bfc2566c5ff77afaa4bca542c5aeb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 10 Dec 2020 13:00:17 -0700 Subject: [PATCH 29/67] physics/GFS_debug.F90: bugfix, zs now in Model and no longer in Sfcprop --- physics/GFS_debug.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 4680f8de7..b5066637d 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -491,10 +491,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end if ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Model%zs', Model%zs) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sh2o', Sfcprop%sh2o) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%smois', Sfcprop%smois) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tslb', Sfcprop%tslb) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zs', Sfcprop%zs) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%clw_surf', Sfcprop%clw_surf) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%qwv_surf', Sfcprop%qwv_surf) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%cndm_surf', Sfcprop%cndm_surf) From e63083120496aa9329285aa91129a8689edaf515 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 15 Dec 2020 16:42:55 +0000 Subject: [PATCH 30/67] Minor bug fixes to unified_ugwp.F90 and drag_suite.F90 --- physics/drag_suite.F90 | 2 +- physics/unified_ugwp.F90 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index eaa1366a8..2e68ceb12 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -1260,7 +1260,7 @@ subroutine drag_suite_run( & eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux+dtauxb)*deltim))**2 + & (rcs*(v1(i,k)+(dtauy+dtauyb)*deltim))**2 ) ! Modify theta tendency - dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim/prslk(i,k) + dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim end if dusfc(i) = dusfc(i) + taud_ls(i,k)*xn(i)*del(i,k) + taud_bl(i,k)*xn(i)*del(i,k) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index fda887f3e..5c0604f86 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -244,7 +244,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, integer, intent(in) :: gwd_opt integer, intent(in), dimension(im) :: kpbl real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma - real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,oa4ss,ol4ss,dx + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx + real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss logical, intent(in) :: flag_for_gwd_generic_tend ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS real(kind=kind_phys), intent(inout), dimension(im) :: elvmax From ea5e44fcc691c9a5fedcb96f13e0ca85259c7844 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 16 Dec 2020 15:51:33 +0000 Subject: [PATCH 31/67] Updated rte submodule --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 566bee9cd..33c8a984c 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d +Subproject commit 33c8a984c17cf41be5d4c2928242e1b4239bfc40 From 37313e512087fc47f51bf12375e724c80fa3c18c Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 16 Dec 2020 17:26:38 +0000 Subject: [PATCH 32/67] Changes from code review --- physics/GFS_rrtmgp_cloud_overlap_pre.F90 | 4 ++-- physics/GFS_rrtmgp_pre.F90 | 14 ++++++------- physics/GFS_rrtmgp_pre.meta | 26 ++++++++++++------------ physics/GFS_rrtmgp_thompsonmp_pre.F90 | 11 +++++----- physics/GFS_rrtmgp_thompsonmp_pre.meta | 10 ++++----- physics/rrtmgp_lw_cloud_optics.F90 | 2 +- physics/rrtmgp_lw_cloud_optics.meta | 2 +- physics/rrtmgp_sw_cloud_optics.F90 | 2 +- 8 files changed, 35 insertions(+), 36 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 index 08bc82d05..05b8ee79e 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 @@ -78,12 +78,12 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra real(kind_phys), dimension(nCol,nLev) :: deltaZ logical :: top_at_1 - if (.not. (doSWrad .or. doLWrad)) return - ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + if (.not. (doSWrad .or. doLWrad)) return + ! What is vertical ordering? top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) if (top_at_1) then diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 25f65567a..73828999f 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -189,24 +189,24 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, errmsg ! Error message integer, intent(out) :: & errflg ! Error flag - real(kind_phys), intent(out) :: & + real(kind_phys), intent(inout) :: & raddt ! Radiation time-step - real(kind_phys), dimension(ncol), intent(out) :: & + real(kind_phys), dimension(ncol), intent(inout) :: & tsfg, & ! Ground temperature tsfa ! Skin temperature - real(kind_phys), dimension(nCol,nLev), intent(out) :: & + real(kind_phys), dimension(nCol,nLev), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer q_lay, & ! Water-vapor mixing ratio (kg/kg) tv_lay, & ! Virtual temperature at model-layers relhum, & ! Relative-humidity at model-layers - qs_lay ! Saturation vapor pressure at model-layers - real(kind_phys), dimension(nCol,nLev+1), intent(out) :: & + qs_lay ! Saturation vapor pressure at model-layers + real(kind_phys), dimension(nCol,nLev+1), intent(inout) :: & p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface - real(kind_phys), dimension(nCol, nLev, nTracers),intent(out) :: & + real(kind_phys), dimension(nCol, nLev, nTracers),intent(inout) :: & tracer ! Array containing trace gases - type(ty_gas_concs),intent(out) :: & + type(ty_gas_concs),intent(inout) :: & gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios ! Local variables diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 136898bb3..d07f9c137 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -262,7 +262,7 @@ dimensions = () type = real kind = kind_phys - intent = out + intent = inout optional = F [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa @@ -271,7 +271,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa @@ -280,7 +280,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [t_lay] standard_name = air_temperature_at_layer_for_RRTMGP @@ -289,7 +289,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [t_lev] standard_name = air_temperature_at_interface_for_RRTMGP @@ -298,7 +298,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys - intent = out + intent = inout optional = F [tsfg] standard_name = surface_ground_temperature_for_radiation @@ -307,7 +307,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [tsfa] standard_name = surface_air_temperature_for_radiation @@ -316,7 +316,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout optional = F [tv_lay] standard_name = virtual_temperature @@ -325,7 +325,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [relhum] standard_name = relative_humidity @@ -334,7 +334,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [qs_lay] standard_name = saturation_vapor_pressure @@ -343,7 +343,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [q_lay] standard_name = water_vapor_mixing_ratio @@ -352,7 +352,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [tracer] standard_name = chemical_tracers @@ -361,7 +361,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) type = real kind = kind_phys - intent = out + intent = inout optional = F [gas_concentrations] standard_name = Gas_concentrations_for_RRTMGP_suite @@ -369,7 +369,7 @@ units = DDT dimensions = () type = ty_gas_concs - intent = out + intent = inout optional = F [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index bd109ddf4..ea27f3d2b 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -95,17 +95,16 @@ subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, do cld_reliq, & ! Cloud liquid effective radius cld_iwp, & ! Cloud ice water path cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac, & ! Precipitation fraction effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for ice cloud-particles (microns) effrin_cldsnow ! Effective radius for snow cloud-particles (microns) ! Outputs - real(kind_phys), dimension(nCol,nLev),intent(out) :: & - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index 2368a7337..90ec59760 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -385,7 +385,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_resnow] standard_name = mean_effective_radius_for_snow_flake @@ -394,7 +394,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_rwp] standard_name = cloud_rain_water_path @@ -403,7 +403,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_rerain] standard_name = mean_effective_radius_for_rain_drop @@ -412,7 +412,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [precip_frac] standard_name = precipitation_fraction_by_layer @@ -421,7 +421,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [errmsg] standard_name = ccpp_error_message diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 023df62ec..341c19fc2 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -323,7 +323,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - real(kind_phys), dimension(ncol,nLev), intent(out) :: & + real(kind_phys), dimension(ncol,nLev), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth ! Local variables diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index cf0418eb4..c57e70a33 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -322,7 +322,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [lw_optical_props_cloudsByBand] standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 92f007a99..f08cd7181 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -281,7 +281,7 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, c0r = (/0.980, 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, & 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/) c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, & - 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) + 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) end subroutine rrtmgp_sw_cloud_optics_init From ea6858b0c75fe662f4a233220acb0c3c79a942a5 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 16 Dec 2020 22:24:09 +0000 Subject: [PATCH 33/67] Added Apache license statement in README.md --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index c1964c445..9000afccc 100644 --- a/README.md +++ b/README.md @@ -15,4 +15,6 @@ For the use of CCPP with its Single Column Model, see the [Single Column Model U For the use of CCPP with NOAA's Unified Forecast System (UFS), see the [UFS Medium-Range Application User's Guide](https://ufs-mrweather-app.readthedocs.io/en/latest/) and the [UFS Weather Model User's Guide](https://ufs-weather-model.readthedocs.io/en/latest/). +The Apache license will be in effect unless superseded by an existing license in specific files. + Questions can be directed to the [CCPP Help Desk](mailto:gmtb-help@ucar.edu). When using the CCPP with NOAA's UFS, questions can be posted in the [UFS Weather Model](https://forums.ufscommunity.org/forum/ufs-weather-model) section of the [UFS Forum](https://forums.ufscommunity.org/) From e1e8c3f3a1717273d52cdeda41063c4d24b7c7fc Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 17 Dec 2020 20:17:27 -0700 Subject: [PATCH 34/67] Move time vary physics from run to timestep_init and remove dependency on GFS DDTs --- physics/GFS_debug.F90 | 6 - physics/GFS_phys_time_vary.fv3.F90 | 655 +++++++------- physics/GFS_phys_time_vary.fv3.meta | 1275 ++++++++++++++++++++++++++- physics/GFS_rad_time_vary.fv3.F90 | 102 +-- physics/GFS_rad_time_vary.fv3.meta | 216 ++++- physics/GFS_rrtmg_setup.F90 | 14 +- physics/GFS_rrtmg_setup.meta | 2 +- physics/GFS_suite_interstitial.F90 | 43 +- physics/GFS_suite_interstitial.meta | 16 + physics/GFS_time_vary_pre.fv3.F90 | 17 +- physics/GFS_time_vary_pre.fv3.meta | 2 +- physics/gcycle.F90 | 411 ++++----- physics/h2o_def.f | 5 + physics/h2o_def.meta | 29 + physics/ozne_def.f | 5 + physics/ozne_def.meta | 29 + 16 files changed, 2110 insertions(+), 717 deletions(-) create mode 100644 physics/h2o_def.meta create mode 100644 physics/ozne_def.meta diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 35b44ca0e..86e175970 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -915,14 +915,10 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup do iomp=0,ompsize-1 if (mpirank==impi .and. omprank==iomp) then ! Print static variables - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%h2o_coeff ', Interstitial%h2o_coeff ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%h2o_pres ', Interstitial%h2o_pres ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ipr ', Interstitial%ipr ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%itc ', Interstitial%itc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%latidxprnt ', Interstitial%latidxprnt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levi ', Interstitial%levi ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levh2o ', Interstitial%levh2o ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levozp ', Interstitial%levozp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%lmk ', Interstitial%lmk ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%lmp ', Interstitial%lmp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nbdlw ', Interstitial%nbdlw ) @@ -934,8 +930,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nspc1 ', Interstitial%nspc1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ntiwx ', Interstitial%ntiwx ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nvdiff ', Interstitial%nvdiff ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oz_coeff ', Interstitial%oz_coeff ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'sum(Interstitial%oz_pres) ', Interstitial%oz_pres ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%phys_hydrostatic ', Interstitial%phys_hydrostatic ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%skip_macro ', Interstitial%skip_macro ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans_aero ', Interstitial%trans_aero ) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 3c894b777..4043b9090 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -11,6 +11,10 @@ module GFS_phys_time_vary use omp_lib #endif + use machine, only : kind_phys + + use mersenne_twister, only: random_setseed, random_number + use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin use ozinterp, only : read_o3data, setindxoz, ozinterpol @@ -23,6 +27,8 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol + use gcycle_mod, only : gcycle + #if 0 !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx @@ -32,10 +38,14 @@ module GFS_phys_time_vary private - public GFS_phys_time_vary_init, GFS_phys_time_vary_run, GFS_phys_time_vary_finalize + public GFS_phys_time_vary_init, GFS_phys_time_vary_timestep_init, GFS_phys_time_vary_timestep_finalize, GFS_phys_time_vary_finalize logical :: is_initialized = .false. + real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys + real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys + contains !> \section arg_table_GFS_phys_time_vary_init Argument Table @@ -43,236 +53,389 @@ module GFS_phys_time_vary !! !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !! @{ - subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, errflg) - - use GFS_typedefs, only: GFS_control_type, GFS_data_type, GFS_interstitial_type + subroutine GFS_phys_time_vary_init ( & + me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & + jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & + jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & + nthrds, errmsg, errflg) implicit none ! Interface variables - type(GFS_data_type), intent(inout) :: Data(:) - type(GFS_control_type), intent(inout) :: Model - type(GFS_interstitial_type), intent(inout) :: Interstitial(:) - integer, intent(in) :: nthrds - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny + logical, intent(in) :: h2o_phys, iaerclm + integer, intent(in) :: idate(:) + real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) + + integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) + real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) + real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) + real(kind_phys), intent(in) :: aer_nm(:,:,:) + integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) + real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) + integer, intent(inout) :: imap(:), jmap(:) + + integer, intent(in) :: nthrds + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables - integer :: nb, nblks, nt integer :: i, j, ix - logical :: non_uniform_blocks + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (is_initialized) return - nblks = size(Model%blksz) - - ! Non-uniform blocks require special handling: instead - ! of nthrds elements of the Interstitial array, there are - ! nthrds+1 elements. The extra Interstitial(nthrds+1) is - ! allocated for the smaller block length of the last block, - ! while all other elements are allocated to the maximum - ! block length (which is the same for all blocks except - ! the last block). - if (minval(Model%blksz)==maxval(Model%blksz)) then - non_uniform_blocks = .false. - else - non_uniform_blocks = .true. - end if - - ! Consistency check - number of threads passed in via the argument list - ! has to match the size of the Interstitial data type. - if (.not. non_uniform_blocks .and. nthrds/=size(Interstitial)) then - write(errmsg,'(*(a))') 'Logic error: nthrds does not match size of Interstitial variable' - errflg = 1 - return - else if (non_uniform_blocks .and. nthrds+1/=size(Interstitial)) then - write(errmsg,'(*(a))') 'Logic error: nthrds+1 does not match size of Interstitial variable ' // & - '(including extra last element for shorter blocksizes)' - errflg = 1 - return - end if - -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nt,nb) & -!$OMP shared (Model,Data,Interstitial,errmsg,errflg) & -!$OMP shared (levozp,oz_coeff,oz_pres) & -!$OMP shared (levh2o,h2o_coeff,h2o_pres) & -!$OMP shared (ntrcaer,nblks,nthrds,non_uniform_blocks) - -#ifdef OPENMP - nt = omp_get_thread_num()+1 -#else - nt = 1 -#endif +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP shared (me,master,ntoz,h2o_phys,im) & +!$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & +!$OMP shared (levozp,oz_coeff,oz_pres,ozpl) & +!$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & +!$OMP shared (iaerclm,ntrcaer,aer_nm,iflip,iccn) & +!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & +!$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & +!$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & +!$OMP private (ix,i,j) !$OMP sections !$OMP section !> - Call read_o3data() to read ozone data - call read_o3data (Model%ntoz, Model%me, Model%master) + call read_o3data (ntoz, me, master) ! Consistency check that the hardcoded values for levozp and ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(Data(1)%Tbd%ozpl, dim=2).ne.levozp) then + ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) + if (size(ozpl, dim=2).ne.levozp) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(Data(1)%Tbd%ozpl, dim=2) + levozp, " /= ", size(ozpl, dim=2) errflg = 1 end if - if (size(Data(1)%Tbd%ozpl, dim=3).ne.oz_coeff) then + if (size(ozpl, dim=3).ne.oz_coeff) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(Data(1)%Tbd%ozpl, dim=3) + oz_coeff, " /= ", size(ozpl, dim=3) errflg = 1 end if !$OMP section !> - Call read_h2odata() to read stratospheric water vapor data - call read_h2odata (Model%h2o_phys, Model%me, Model%master) + call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) - if (size(Data(1)%Tbd%h2opl, dim=2).ne.levh2o) then + if (size(h2opl, dim=2).ne.levh2o) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "levh2o from read_h2odata does not match value in GFS_typedefs.F90: ", & - levh2o, " /= ", size(Data(1)%Tbd%h2opl, dim=2) + levh2o, " /= ", size(h2opl, dim=2) errflg = 1 end if - if (size(Data(1)%Tbd%h2opl, dim=3).ne.h2o_coeff) then + if (size(h2opl, dim=3).ne.h2o_coeff) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "h2o_coeff from read_h2odata does not match value in GFS_typedefs.F90: ", & - h2o_coeff, " /= ", size(Data(1)%Tbd%h2opl, dim=3) + h2o_coeff, " /= ", size(h2opl, dim=3) errflg = 1 end if !$OMP section !> - Call read_aerdata() to read aerosol climatology - if (Model%iaerclm) then + if (iaerclm) then ! Consistency check that the value for ntrcaerm set in GFS_typedefs.F90 - ! and used to allocate Tbd%aer_nm matches the value defined in aerclm_def - if (size(Data(1)%Tbd%aer_nm, dim=3).ne.ntrcaerm) then + ! and used to allocate aer_nm matches the value defined in aerclm_def + if (size(aer_nm, dim=3).ne.ntrcaerm) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "ntrcaerm from aerclm_def does not match value in GFS_typedefs.F90: ", & - ntrcaerm, " /= ", size(Data(1)%Tbd%aer_nm, dim=3) + ntrcaerm, " /= ", size(aer_nm, dim=3) errflg = 1 else ! Update the value of ntrcaer in aerclm_def with the value defined ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. - ! If Model%iaerclm is .true., then ntrcaer == ntrcaerm - ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) + ! If iaerclm is .true., then ntrcaer == ntrcaerm + ntrcaer = size(aer_nm, dim=3) ! Read aerosol climatology - call read_aerdata (Model%me,Model%master,Model%iflip,Model%idate,errmsg,errflg) + call read_aerdata (me,master,iflip,idate,errmsg,errflg) endif else ! Update the value of ntrcaer in aerclm_def with the value defined ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. - ! If Model%iaerclm is .false., then ntrcaer == 1 - ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) + ! If iaerclm is .false., then ntrcaer == 1 + ntrcaer = size(aer_nm, dim=3) endif !$OMP section !> - Call read_cidata() to read IN and CCN data - if (Model%iccn == 1) then - call read_cidata ( Model%me, Model%master) + if (iccn == 1) then + call read_cidata (me,master) ! No consistency check needed for in/ccn data, all values are ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP end sections - - ! Update values of oz_pres in Interstitial data type for all threads - if (Model%ntoz > 0) then - Interstitial(nt)%oz_pres = oz_pres -!$OMP single - if (non_uniform_blocks) then - ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres - Interstitial(nthrds+1)%oz_pres = oz_pres - end if -!$OMP end single nowait - end if - - ! Update values of h2o_pres in Interstitial data type for all threads - if (Model%h2o_phys) then - Interstitial(nt)%h2o_pres = h2o_pres -!$OMP single - if (non_uniform_blocks) then - ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres - Interstitial(nthrds+1)%h2o_pres = h2o_pres - end if -!$OMP end single nowait - end if - +!$OMP barrier +!$OMP section !> - Call setindxoz() to initialize ozone data - if (Model%ntoz > 0) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxoz (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_o3, & - Data(nb)%Grid%jindx2_o3, Data(nb)%Grid%ddy_o3) - enddo -!$OMP end do + if (ntoz > 0) then + call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3) endif +!$OMP section !> - Call setindxh2o() to initialize stratospheric water vapor data - if (Model%h2o_phys) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxh2o (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_h, & - Data(nb)%Grid%jindx2_h, Data(nb)%Grid%ddy_h) - enddo -!$OMP end do + if (h2o_phys) then + call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h) endif +!$OMP section !> - Call setindxaer() to initialize aerosols data - if (Model%iaerclm) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxaer (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_aer, & - Data(nb)%Grid%jindx2_aer, Data(nb)%Grid%ddy_aer, Data(nb)%Grid%xlon_d, & - Data(nb)%Grid%iindx1_aer, Data(nb)%Grid%iindx2_aer, Data(nb)%Grid%ddx_aer, & - Model%me, Model%master) - enddo -!$OMP end do + if (iaerclm) then + call setindxaer (im, xlat_d, jindx1_aer, & + jindx2_aer, ddy_aer, xlon_d, & + iindx1_aer, iindx2_aer, ddx_aer, & + me, master) endif +!$OMP section !> - Call setindxci() to initialize IN and CCN data - if (Model%iccn == 1) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxci (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_ci, & - Data(nb)%Grid%jindx2_ci, Data(nb)%Grid%ddy_ci, Data(nb)%Grid%xlon_d, & - Data(nb)%Grid%iindx1_ci, Data(nb)%Grid%iindx2_ci, Data(nb)%Grid%ddx_ci) - enddo -!$OMP end do + if (iccn == 1) then + call setindxci (im, xlat_d, jindx1_ci, & + jindx2_ci, ddy_ci, xlon_d, & + iindx1_ci, iindx2_ci, ddx_ci) endif -!$OMP end parallel - - !--- initial calculation of maps local ix -> global i and j, store in Tbd +!$OMP section + !--- initial calculation of maps local ix -> global i and j ix = 0 - nb = 1 - do j = 1,Model%ny - do i = 1,Model%nx + do j = 1,ny + do i = 1,nx ix = ix + 1 - if (ix > Model%blksz(nb)) then - ix = 1 - nb = nb + 1 - endif - Data(nb)%Tbd%jmap(ix) = j - Data(nb)%Tbd%imap(ix) = i + jmap(ix) = j + imap(ix) = i enddo enddo +!$OMP end sections + +!$OMP end parallel + +#if 0 + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do nb = 1, nblks + do ix = 1, Model%blksz(nb) + Data(nb)%Sfcprop%sncovr(ix) = 0.0 + if (Data(nb)%Sfcprop%slmsk(ix) > 0.001) then + vegtyp = Data(nb)%Sfcprop%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Data(nb)%Sfcprop%weasd(ix)/snupx(vegtyp) + if (0.001*Data(nb)%Sfcprop%weasd(ix) < snupx(vegtyp)) then + Data(nb)%Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Data(nb)%Sfcprop%sncovr(ix) = 1.0 + endif + endif + enddo + enddo + endif + endif +#endif + is_initialized = .true. end subroutine GFS_phys_time_vary_init !! @} +!> \section arg_table_GFS_phys_time_vary_timestep_init Argument Table +!! \htmlinclude GFS_phys_time_vary_timestep_init.html +!! +!>\section gen_GFS_phys_time_vary_timestep_init GFS_phys_time_vary_timestep_init General Algorithm +!! @{ + subroutine GFS_phys_time_vary_timestep_init ( & + me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & + imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & + jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & + jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & + imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, kice, & + ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & + lakefrac, min_seaice, min_lakeice, smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, & + hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd, & + slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & + nsswr, imfdeepcnv, iccn, nscyc, ntoz + integer, intent(in) :: idate(:) + real(kind_phys), intent(in) :: fhswr, fhour + logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm + real(kind_phys), intent(out) :: clstp + integer, intent(in) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(in) :: ddy_o3(:), ddy_h(:) + real(kind_phys), intent(inout) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(in) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) + real(kind_phys), intent(in) :: ddy_aer(:), ddx_aer(:) + real(kind_phys), intent(inout) :: aer_nm(:,:,:) + integer, intent(in) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) + real(kind_phys), intent(in) :: ddy_ci(:), ddx_ci(:) + real(kind_phys), intent(inout) :: in_nm(:,:), ccn_nm(:,:) + integer, intent(in) :: imap(:), jmap(:) + real(kind_phys), intent(in) :: prsl(:,:) + integer, intent(in) :: seed0 + real(kind_phys), intent(out) :: rann(:,:) + ! For gcycle only + integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, kice + integer, intent(in) :: ialb, isot, ivegsrc + character(len=*), intent(in) :: input_nml_file(:) + logical, intent(in) :: use_ufo, nst_anl, frac_grid + real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & + xlat_d(:), xlon_d(:) + ! + real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), tiice(:,:), tg3(:), & + tref(:), tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & + facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & + zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & + canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & + snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + ! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, j, k, iseed, iskip, ix + real(kind=kind_phys) :: wrk(1) + real(kind=kind_phys) :: rannie(cny) + real(kind=kind_phys) :: rndval(cnx*cny*nrcm) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization status + if (.not.is_initialized) then + write(errmsg,'(*(a))') "Logic error: GFS_phys_time_vary_timestep_init called before GFS_phys_time_vary_init" + errflg = 1 + return + end if + + !--- switch for saving convective clouds - cnvc90.f + !--- aka Ken Campana/Yu-Tai Hou legacy + if ((mod(kdt,nsswr) == 0) .and. (lsswr)) then + !--- initialize,accumulate,convert + clstp = 1100 + min(fhswr/con_hr,fhour,con_99) + elseif (mod(kdt,nsswr) == 0) then + !--- accumulate,convert + clstp = 0100 + min(fhswr/con_hr,fhour,con_99) + elseif (lsswr) then + !--- initialize,accumulate + clstp = 1100 + else + !--- accumulate + clstp = 0100 + endif + + !--- random number needed for RAS and old SAS and when cal_pre=.true. + ! imfdeepcnv < 0 when ras = .true. + if ( (imfdeepcnv <= 0 .or. cal_pre) .and. random_clds ) then + + iseed = mod(con_100*sqrt(fhour*con_hr),1.0d9) + seed0 + call random_setseed(iseed) + call random_number(wrk) + do i = 1,cnx*nrcm + iseed = iseed + nint(wrk(1)*1000.0) * i + call random_setseed(iseed) + call random_number(rannie) + rndval(1+(i-1)*cny:i*cny) = rannie(1:cny) + enddo + + do k = 1,nrcm + iskip = (k-1)*cnx*cny + do ix=1,im + j = jmap(ix) + i = imap(ix) + rann(ix,k) = rndval(i+isc-1 + (j+jsc-2)*cnx + iskip) + enddo + enddo + + endif ! imfdeepcnv, cal_re, random_clds + +!> - Call ozinterpol() to make ozone interpolation + if (ntoz > 0) then + call ozinterpol (me, im, idate, fhour, & + jindx1_o3, jindx2_o3, & + ozpl, ddy_o3) + endif + +!> - Call h2ointerpol() to make stratospheric water vapor data interpolation + if (h2o_phys) then + call h2ointerpol (me, im, idate, fhour, & + jindx1_h, jindx2_h, & + h2opl, ddy_h) + endif + +!> - Call aerinterpol() to make aerosol interpolation + if (iaerclm) then + call aerinterpol (me, master, im, idate, fhour, & + jindx1_aer, jindx2_aer, & + ddy_aer, iindx1_aer, & + iindx2_aer, ddx_aer, & + levs, prsl, aer_nm) + endif + +!> - Call ciinterpol() to make IN and CCN data interpolation + if (iccn == 1) then + call ciinterpol (me, im, idate, fhour, & + jindx1_ci, jindx2_ci, & + ddy_ci, iindx1_ci, & + iindx2_ci, ddx_ci, & + levs, prsl, in_nm, ccn_nm) + endif + +!> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs + if (nscyc > 0) then + if (mod(kdt,nscyc) == 1) THEN + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, kice, idate, ialb, isot, ivegsrc, use_ufo, & + nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, frac_grid, & + smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, hice, fice, & + facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd,& + slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, imap, jmap) + endif + endif + + end subroutine GFS_phys_time_vary_timestep_init +!! @} + +!> \section arg_table_GFS_phys_time_vary_timestep_finalize Argument Table +!! \htmlinclude GFS_phys_time_vary_timestep_finalize.html +!! +!>\section gen_GFS_phys_time_vary_timestep_finalize GFS_phys_time_vary_timestep_finalize General Algorithm +!! @{ + subroutine GFS_phys_time_vary_timestep_finalize (errmsg, errflg) + + implicit none + + ! Interface variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine GFS_phys_time_vary_timestep_finalize +!! @} !> \section arg_table_GFS_phys_time_vary_finalize Argument Table !! \htmlinclude GFS_phys_time_vary_finalize.html @@ -316,215 +479,5 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) end subroutine GFS_phys_time_vary_finalize - -!> \section arg_table_GFS_phys_time_vary_run Argument Table -!! \htmlinclude GFS_phys_time_vary_run.html -!! -!>\section gen_GFS_phys_time_vary_run GFS_phys_time_vary_run General Algorithm -!> @{ - subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, errflg) - - use mersenne_twister, only: random_setseed, random_number - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_data_type - - implicit none - - ! Interface variables - type(GFS_data_type), intent(inout) :: Data(:) - type(GFS_control_type), intent(inout) :: Model - integer, intent(in) :: nthrds - logical, intent(in) :: first_time_step - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys - real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys - real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - - integer :: i, j, k, iseed, iskip, ix, nb, nblks, kdt_rad, vegtyp - real(kind=kind_phys) :: sec_zero, rsnow - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(Model%cny) - real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Check initialization status - if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_phys_time_vary_run called before GFS_phys_time_vary_init" - errflg = 1 - return - end if - - nblks = size(Model%blksz) - - !--- switch for saving convective clouds - cnvc90.f - !--- aka Ken Campana/Yu-Tai Hou legacy - if ((mod(Model%kdt,Model%nsswr) == 0) .and. (Model%lsswr)) then - !--- initialize,accumulate,convert - Model%clstp = 1100 + min(Model%fhswr/con_hr,Model%fhour,con_99) - elseif (mod(Model%kdt,Model%nsswr) == 0) then - !--- accumulate,convert - Model%clstp = 0100 + min(Model%fhswr/con_hr,Model%fhour,con_99) - elseif (Model%lsswr) then - !--- initialize,accumulate - Model%clstp = 1100 - else - !--- accumulate - Model%clstp = 0100 - endif - -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nb,iskip,ix,i,j,k) & -!$OMP shared (Model,Data,iseed,wrk,rannie,rndval) & -!$OMP shared (nblks) - - !--- random number needed for RAS and old SAS and when cal_pre=.true. - ! Model%imfdeepcnv < 0 when Model%ras = .true. - if ( (Model%imfdeepcnv <= 0 .or. Model%cal_pre) .and. Model%random_clds ) then -!$OMP single - iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0 - call random_setseed(iseed) - call random_number(wrk) - do i = 1,Model%cnx*Model%nrcm - iseed = iseed + nint(wrk(1)*1000.0) * i - call random_setseed(iseed) - call random_number(rannie) - rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny) - enddo -!$OMP end single - - do k = 1,Model%nrcm - iskip = (k-1)*Model%cnx*Model%cny -!$OMP do schedule (dynamic,1) - do nb=1,nblks - do ix=1,Model%blksz(nb) - j = Data(nb)%Tbd%jmap(ix) - i = Data(nb)%Tbd%imap(ix) - Data(nb)%Tbd%rann(ix,k) = rndval(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + iskip) - enddo - enddo -!$OMP end do - enddo - endif ! imfdeepcnv, cal_re, random_clds - -!> - Call ozinterpol() to make ozone interpolation - if (Model%ntoz > 0) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call ozinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_o3, Data(nb)%Grid%jindx2_o3, & - Data(nb)%Tbd%ozpl, Data(nb)%Grid%ddy_o3) - enddo -!$OMP end do - endif - -!> - Call h2ointerpol() to make stratospheric water vapor data interpolation - if (Model%h2o_phys) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call h2ointerpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_h, Data(nb)%Grid%jindx2_h, & - Data(nb)%Tbd%h2opl, Data(nb)%Grid%ddy_h) - enddo -!$OMP end do - endif - -!> - Call aerinterpol() to make aerosol interpolation - if (Model%iaerclm) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call aerinterpol (Model%me, Model%master, Model%blksz(nb), & - Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_aer, Data(nb)%Grid%jindx2_aer, & - Data(nb)%Grid%ddy_aer,Data(nb)%Grid%iindx1_aer, & - Data(nb)%Grid%iindx2_aer,Data(nb)%Grid%ddx_aer, & - Model%levs,Data(nb)%Statein%prsl, & - Data(nb)%Tbd%aer_nm) - enddo -!$OMP end do - endif - -!> - Call ciinterpol() to make IN and CCN data interpolation - if (Model%iccn == 1) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call ciinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_ci, Data(nb)%Grid%jindx2_ci, & - Data(nb)%Grid%ddy_ci,Data(nb)%Grid%iindx1_ci, & - Data(nb)%Grid%iindx2_ci,Data(nb)%Grid%ddx_ci, & - Model%levs,Data(nb)%Statein%prsl, & - Data(nb)%Tbd%in_nm, Data(nb)%Tbd%ccn_nm) - enddo -!$OMP end do - endif - -!$OMP end parallel - -!> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs - if (Model%nscyc > 0) then - if (mod(Model%kdt,Model%nscyc) == 1) THEN - call gcycle (nblks, nthrds, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) - endif - endif - - !--- determine if diagnostics buckets need to be cleared - sec_zero = nint(Model%fhzero*con_hr) - if (sec_zero >= nint(max(Model%fhswr,Model%fhlwr))) then - if (mod(Model%kdt,Model%nszero) == 1) then - do nb = 1,nblks - call Data(nb)%Intdiag%rad_zero (Model) - call Data(nb)%Intdiag%phys_zero (Model) - !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED - enddo - endif - else - if (mod(Model%kdt,Model%nszero) == 1) then - do nb = 1,nblks - call Data(nb)%Intdiag%phys_zero (Model) - !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED - enddo - endif - kdt_rad = nint(min(Model%fhswr,Model%fhlwr)/Model%dtp) - if (mod(Model%kdt, kdt_rad) == 1) then - do nb = 1,nblks - call Data(nb)%Intdiag%rad_zero (Model) - !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED - enddo - endif - endif - -#if 0 - !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) - if (first_time_step) then - if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then - !--- compute sncovr from existing variables - !--- code taken directly from read_fix.f - do nb = 1, nblks - do ix = 1, Model%blksz(nb) - Data(nb)%Sfcprop%sncovr(ix) = 0.0 - if (Data(nb)%Sfcprop%slmsk(ix) > 0.001) then - vegtyp = Data(nb)%Sfcprop%vtype(ix) - if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*Data(nb)%Sfcprop%weasd(ix)/snupx(vegtyp) - if (0.001*Data(nb)%Sfcprop%weasd(ix) < snupx(vegtyp)) then - Data(nb)%Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) - else - Data(nb)%Sfcprop%sncovr(ix) = 1.0 - endif - endif - enddo - enddo - endif - endif -#endif - - end subroutine GFS_phys_time_vary_run -!> @} - end module GFS_phys_time_vary !> @} diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 72a7ce207..e78a13e4b 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -7,28 +7,304 @@ [ccpp-arg-table] name = GFS_phys_time_vary_init type = scheme -[Data] - standard_name = GFS_data_type_instance_all_blocks - long_name = Fortran DDT containing FV3-GFS data - units = DDT - dimensions = (ccpp_block_count) - type = GFS_data_type - intent = inout + +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + 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 +[ntoz] + standard_name = index_for_ozone + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in optional = F -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT +[h2o_phys] + standard_name = flag_for_stratospheric_water_vapor_physics + long_name = flag for stratospheric water vapor physics + units = flag dimensions = () - type = GFS_control_type + type = logical + intent = in + optional = F +[iaerclm] + standard_name = flag_for_aerosol_input_MG_radiation + long_name = flag for using aerosols in Morrison-Gettelman MP_radiation + units = flag + dimensions = () + type = logical + intent = in + optional = F +[iccn] + standard_name = flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics + long_name = flag for IN and CCN forcing for morrison gettelman microphysics + units = none + dimensions = () + type = integer + intent = in + optional = F +[iflip] + standard_name = flag_for_vertical_index_direction_control + long_name = iflip - is not the same as flipv + units = flag + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nx] + standard_name = number_of_points_in_x_direction_for_this_MPI_rank + long_name = number of points in x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[ny] + standard_name = number_of_points_in_y_direction_for_this_MPI_rank + long_name = number of points in y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[jindx1_o3] + standard_name = lower_ozone_interpolation_index + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer intent = inout optional = F -[Interstitial] - standard_name = GFS_interstitial_type_instance_all_threads - long_name = Fortran DDT containing FV3-GFS interstitial data - units = DDT - dimensions = (omp_threads) - type = GFS_interstitial_type +[jindx2_o3] + standard_name = upper_ozone_interpolation_index + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddy_o3] + standard_name = ozone_interpolation_weight + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = various + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) + type = real + kind = kind_phys + intent = in + optional = F +[jindx1_h] + standard_name = lower_water_vapor_interpolation_index + long_name = interpolation low index for stratospheric water vapor + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[jindx2_h] + standard_name = upper_water_vapor_interpolation_index + long_name = interpolation high index for stratospheric water vapor + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddy_h] + standard_name = water_vapor_interpolation_weight + long_name = interpolation high index for stratospheric water vapor + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[h2opl] + standard_name = h2o_forcing + long_name = water forcing data + units = various + dimensions = (horizontal_dimension,vertical_dimension_of_h2o_forcing_data,number_of_coefficients_in_h2o_forcing_data) + type = real + kind = kind_phys + intent = in + optional = F +[jindx1_aer] + standard_name = lower_aerosol_y_interpolation_index + long_name = interpolation low index for prescribed aerosols in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[jindx2_aer] + standard_name = upper_aerosol_y_interpolation_index + long_name = interpolation high index for prescribed aerosols in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddy_aer] + standard_name = aerosol_y_interpolation_weight + long_name = interpolation high index for prescribed aerosols in the y direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[iindx1_aer] + standard_name = lower_aerosol_x_interpolation_index + long_name = interpolation low index for prescribed aerosols in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[iindx2_aer] + standard_name = upper_aerosol_x_interpolation_index + long_name = interpolation high index for prescribed aerosols in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddx_aer] + standard_name = aerosol_x_interpolation_weight + long_name = interpolation high index for prescribed aerosols in the x direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[aer_nm] + standard_name = aerosol_number_concentration_from_gocart_aerosol_climatology + long_name = GOCART aerosol climatology number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = in + optional = F +[jindx1_ci] + standard_name = lower_cloud_nuclei_y_interpolation_index + long_name = interpolation low index for ice and cloud condensation nuclei in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[jindx2_ci] + standard_name = upper_cloud_nuclei_y_interpolation_index + long_name = interpolation high index for ice and cloud condensation nuclei in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddy_ci] + standard_name = cloud_nuclei_y_interpolation_weight + long_name = interpolation high index for ice and cloud condensation nuclei in the y direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[iindx1_ci] + standard_name = lower_cloud_nuclei_x_interpolation_index + long_name = interpolation low index for ice and cloud condensation nuclei in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[iindx2_ci] + standard_name = upper_cloud_nuclei_x_interpolation_index + long_name = interpolation high index for ice and cloud condensation nuclei in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[ddx_ci] + standard_name = cloud_nuclei_x_interpolation_weight + long_name = interpolation high index for ice and cloud condensation nuclei in the x direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[imap] + standard_name = map_of_block_column_number_to_global_i_index + long_name = map of local index ix to global index i for this block + units = none + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[jmap] + standard_name = map_of_block_column_number_to_global_j_index + long_name = map of local index ix to global index j for this block + units = none + dimensions = (horizontal_dimension) + type = integer intent = inout optional = F [nthrds] @@ -81,24 +357,440 @@ ######################################################################## [ccpp-arg-table] - name = GFS_phys_time_vary_run + name = GFS_phys_time_vary_timestep_init type = scheme -[Data] - standard_name = GFS_data_type_instance_all_blocks - long_name = Fortran DDT containing FV3-GFS data - units = DDT - dimensions = (ccpp_block_count) - type = GFS_data_type - intent = inout +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + 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 +[cnx] + standard_name = number_of_points_in_x_direction_for_this_cubed_sphere_face + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in + optional = F +[cny] + standard_name = number_of_points_in_y_direction_for_this_cubed_sphere_face + long_name = number of points in y direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in + optional = F +[isc] + standard_name = starting_x_index_for_this_MPI_rank + long_name = starting index in the x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[jsc] + standard_name = starting_y_index_for_this_MPI_rank + long_name = starting index in the y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[nrcm] + standard_name = array_dimension_of_random_number + long_name = second dimension of random number stream for RAS + units = count + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + 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 +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[nsswr] + standard_name = number_of_timesteps_between_shortwave_radiation_calls + long_name = number of timesteps between shortwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[fhswr] + standard_name = frequency_for_shortwave_radiation + long_name = frequency for shortwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[imfdeepcnv] + standard_name = flag_for_mass_flux_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[cal_pre] + standard_name = flag_for_precipitation_type_algorithm + long_name = flag controls precip type algorithm + units = flag + dimensions = () + type = logical + intent = in + optional = F +[random_clds] + standard_name = flag_for_random_clouds_for_RAS + long_name = flag for using random clouds with the RAS scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[nscyc] + standard_name = number_of_timesteps_between_surface_cycling_calls + long_name = number of timesteps between surface cycling calls + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntoz] + standard_name = index_for_ozone + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in + optional = F +[h2o_phys] + standard_name = flag_for_stratospheric_water_vapor_physics + long_name = flag for stratospheric water vapor physics + units = flag + dimensions = () + type = logical + intent = in optional = F -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT +[iaerclm] + standard_name = flag_for_aerosol_input_MG_radiation + long_name = flag for using aerosols in Morrison-Gettelman MP_radiation + units = flag dimensions = () - type = GFS_control_type + type = logical + intent = in + optional = F +[iccn] + standard_name = flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics + long_name = flag for IN and CCN forcing for morrison gettelman microphysics + units = none + dimensions = () + type = integer + intent = in + optional = F +[clstp] + standard_name = convective_cloud_switch + long_name = index used by cnvc90 (for convective clouds) + units = none + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[jindx1_o3] + standard_name = lower_ozone_interpolation_index + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jindx2_o3] + standard_name = upper_ozone_interpolation_index + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddy_o3] + standard_name = ozone_interpolation_weight + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = various + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) + type = real + kind = kind_phys intent = inout optional = F +[jindx1_h] + standard_name = lower_water_vapor_interpolation_index + long_name = interpolation low index for stratospheric water vapor + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jindx2_h] + standard_name = upper_water_vapor_interpolation_index + long_name = interpolation high index for stratospheric water vapor + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddy_h] + standard_name = water_vapor_interpolation_weight + long_name = interpolation high index for stratospheric water vapor + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[h2opl] + standard_name = h2o_forcing + long_name = water forcing data + units = various + dimensions = (horizontal_dimension,vertical_dimension_of_h2o_forcing_data,number_of_coefficients_in_h2o_forcing_data) + type = real + kind = kind_phys + intent = inout + optional = F +[jindx1_aer] + standard_name = lower_aerosol_y_interpolation_index + long_name = interpolation low index for prescribed aerosols in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jindx2_aer] + standard_name = upper_aerosol_y_interpolation_index + long_name = interpolation high index for prescribed aerosols in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddy_aer] + standard_name = aerosol_y_interpolation_weight + long_name = interpolation high index for prescribed aerosols in the y direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[iindx1_aer] + standard_name = lower_aerosol_x_interpolation_index + long_name = interpolation low index for prescribed aerosols in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[iindx2_aer] + standard_name = upper_aerosol_x_interpolation_index + long_name = interpolation high index for prescribed aerosols in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddx_aer] + standard_name = aerosol_x_interpolation_weight + long_name = interpolation high index for prescribed aerosols in the x direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[aer_nm] + standard_name = aerosol_number_concentration_from_gocart_aerosol_climatology + long_name = GOCART aerosol climatology number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = inout + optional = F +[jindx1_ci] + standard_name = lower_cloud_nuclei_y_interpolation_index + long_name = interpolation low index for ice and cloud condensation nuclei in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jindx2_ci] + standard_name = upper_cloud_nuclei_y_interpolation_index + long_name = interpolation high index for ice and cloud condensation nuclei in the y direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddy_ci] + standard_name = cloud_nuclei_y_interpolation_weight + long_name = interpolation high index for ice and cloud condensation nuclei in the y direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[iindx1_ci] + standard_name = lower_cloud_nuclei_x_interpolation_index + long_name = interpolation low index for ice and cloud condensation nuclei in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[iindx2_ci] + standard_name = upper_cloud_nuclei_x_interpolation_index + long_name = interpolation high index for ice and cloud condensation nuclei in the x direction + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[ddx_ci] + standard_name = cloud_nuclei_x_interpolation_weight + long_name = interpolation high index for ice and cloud condensation nuclei in the x direction + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[in_nm] + standard_name = ice_nucleation_number + long_name = ice nucleation number in MG MP + units = kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ccn_nm] + standard_name = tendency_of_ccn_activated_number + long_name = tendency of ccn activated number + units = kg-1 s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[imap] + standard_name = map_of_block_column_number_to_global_i_index + long_name = map of local index ix to global index i for this block + units = none + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jmap] + standard_name = map_of_block_column_number_to_global_j_index + long_name = map of local index ix to global index j for this block + units = none + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[seed0] + standard_name = seed_random_numbers_RAS + long_name = random number seed for the RAS scheme + units = none + dimensions = () + type = integer + intent = in + optional = F +[rann] + standard_name = random_number_array + long_name = random number array (0-1) + units = none + dimensions = (horizontal_dimension,array_dimension_of_random_number) + type = real + kind = kind_phys + intent = out + optional = F [nthrds] standard_name = omp_threads long_name = number of OpenMP threads available for physics schemes @@ -107,14 +799,529 @@ type = integer intent = in optional = F -[first_time_step] - standard_name = flag_for_first_time_step - long_name = flag for first time step for time integration loop (cold/warmstart) +[nx] + standard_name = number_of_points_in_x_direction_for_this_MPI_rank + long_name = number of points in x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[ny] + standard_name = number_of_points_in_y_direction_for_this_MPI_rank + long_name = number of points in y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[nsst] + standard_name = flag_for_nsstm_run + long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 + units = flag + dimensions = () + type = integer + intent = in + optional = F +[tile_num] + standard_name = number_of_tile + long_name = tile number + units = none + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for file opens + units = none + dimensions = () + type = integer + intent = in + optional = F +[lsoil] + standard_name = soil_vertical_dimension + long_name = number of soil layers + 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 +[ialb] + standard_name = flag_for_using_climatology_albedo + long_name = flag for using climatology alb, based on sfc type + units = flag + dimensions = () + type = integer + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = namelist filename for internal file reads + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=256 + intent = in + optional = F +[use_ufo] + standard_name = flag_for_gcycle_surface_option + long_name = flag for gcycle surface option + units = flag + dimensions = () + type = logical + intent = in + optional = F +[nst_anl] + standard_name = flag_for_nsstm_analysis_in_gcycle + long_name = flag for NSSTM analysis in gcycle/sfcsub + units = flag + dimensions = () + type = logical + intent = in + optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid units = flag dimensions = () type = logical intent = in optional = F +[fhcyc] + standard_name = frequency_for_surface_cycling_calls + long_name = frequency for surface cycling calls + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[phour] + standard_name = forecast_time_at_previous_timestep + long_name = forecast time at the previous timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = frac + dimensions = () + 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 = inout + 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 = inout + 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 = inout + optional = F +[tiice] + 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 = 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 = inout + optional = F +[tref] + standard_name = sea_surface_reference_temperature + long_name = sea surface reference temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (flag_for_nsstm_run > 0) + intent = inout + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tisfc] + standard_name = sea_ice_temperature + long_name = sea ice surface skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[facsf] + standard_name =fractional_coverage_with_strong_cosz_dependency + long_name = fractional coverage with strong cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[facwf] + standard_name = fractional_coverage_with_weak_cosz_dependency + long_name = fractional coverage with weak cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alvsf] + standard_name = mean_vis_albedo_with_strong_cosz_dependency + long_name = mean vis albedo with strong cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alvwf] + standard_name = mean_vis_albedo_with_weak_cosz_dependency + long_name = mean vis albedo with weak cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alnsf] + standard_name = mean_nir_albedo_with_strong_cosz_dependency + long_name = mean nir albedo with strong cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alnwf] + standard_name = mean_nir_albedo_with_weak_cosz_dependency + long_name = mean nir albedo with weak cosz dependency + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zorlo] + standard_name = surface_roughness_length_over_ocean + long_name = surface roughness length over ocean + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slope] + standard_name = surface_slope_classification_real + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = maximum snow albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy water amount + units = kg m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vfrac] + standard_name = vegetation_area_fraction + long_name = areal fractional cover of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + 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 +[stype] + standard_name = soil_type_classification_real + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[shdmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowd] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cv] + standard_name = fraction_of_convective_cloud + long_name = fraction of convective cloud + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cvb] + standard_name = pressure_at_bottom_of_convective_cloud + long_name = convective cloud bottom pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cvt] + standard_name = pressure_at_top_of_convective_cloud + long_name = convective cloud top pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[oro] + standard_name = orography + long_name = orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[oro_uf] + standard_name = orography_unfiltered + long_name = unfiltered orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = GFS_phys_time_vary_timestep_finalize + type = scheme [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 index f30bf93f9..a081ddcf1 100644 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -6,99 +6,87 @@ module GFS_rad_time_vary private - public GFS_rad_time_vary_init, GFS_rad_time_vary_run, GFS_rad_time_vary_finalize + public GFS_rad_time_vary_timestep_init contains - subroutine GFS_rad_time_vary_init - end subroutine GFS_rad_time_vary_init - !>\defgroup mod_GFS_rad_time_vary GFS Radiation Time Update !> @{ -!> \section arg_table_GFS_rad_time_vary_run Argument Table -!! \htmlinclude GFS_rad_time_vary_run.html +!> \section arg_table_GFS_rad_time_vary_timestep_init Argument Table +!! \htmlinclude GFS_rad_time_vary_timestep_init.html !! - subroutine GFS_rad_time_vary_run (Model, Data, nthrds, errmsg, errflg) + subroutine GFS_rad_time_vary_timestep_init ( & + lslwr, lsswr, isubc_lw, isubc_sw, icsdsw, icsdlw, cnx, cny, isc, jsc, & + imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & + ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) use physparam, only: ipsd0, ipsdlim, iaerflg use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, & - GFS_data_type use radcons, only: qmin, con_100 implicit none - type(GFS_control_type), intent(inout) :: Model - type(GFS_data_type), intent(inout) :: Data(:) - integer, intent(in) :: nthrds + ! Interface variables + integer, intent(in) :: isubc_lw, isubc_sw, cnx, cny, isc, jsc, kdt + integer, intent(in) :: imp_physics, imp_physics_zhao_carr + logical, intent(in) :: lslwr, lsswr + integer, intent(inout) :: icsdsw(:), icsdlw(:) + integer, intent(in) :: imap(:), jmap(:) + real(kind_phys), intent(in) :: sec + real(kind_phys), intent(inout) :: ps_2delt(:) + real(kind_phys), intent(inout) :: ps_1delt(:) + real(kind_phys), intent(inout) :: t_2delt(:,:) + real(kind_phys), intent(inout) :: t_1delt(:,:) + real(kind_phys), intent(inout) :: qv_2delt(:,:) + real(kind_phys), intent(inout) :: qv_1delt(:,:) + real(kind_phys), intent(in) :: t(:,:), qv(:,:), ps(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - !--- local variables + ! Local variables type (random_stat) :: stat - integer :: ix, nb, j, i, nblks, ipseed - integer :: numrdm(Model%cnx*Model%cny*2) + integer :: ix, j, i, nblks, ipseed + integer :: numrdm(cnx*cny*2) ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - if (Model%lsswr .or. Model%lslwr) then - - nblks = size(Model%blksz) - - !--- call to GFS_radupdate_run is now in GFS_rrtmg_setup_run + if (lsswr .or. lslwr) then -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nb,ix,i,j) & -!$OMP shared (Model,Data,ipsdlim,ipsd0,ipseed) & -!$OMP shared (numrdm,stat,nblks) + !--- call to GFS_radupdate_timestep_init is now in GFS_rrtmg_setup_timestep_init !--- set up random seed index in a reproducible way for entire cubed-sphere face (lat-lon grid) - if ((Model%isubc_lw==2) .or. (Model%isubc_sw==2)) then -!$OMP single - ipseed = mod(nint(con_100*sqrt(Model%sec)), ipsdlim) + 1 + ipsd0 + if ((isubc_lw==2) .or. (isubc_sw==2)) then + ipseed = mod(nint(con_100*sqrt(sec)), ipsdlim) + 1 + ipsd0 call random_setseed (ipseed, stat) call random_index (ipsdlim, numrdm, stat) -!$OMP end single - -!$OMP do schedule (dynamic,1) - do nb=1,nblks - do ix=1,Model%blksz(nb) - j = Data(nb)%Tbd%jmap(ix) - i = Data(nb)%Tbd%imap(ix) - !--- for testing purposes, replace numrdm with '100' - Data(nb)%Tbd%icsdsw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx) - Data(nb)%Tbd%icsdlw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + Model%cnx*Model%cny) - enddo + + do ix=1,size(jmap) + j = jmap(ix) + i = imap(ix) + !--- for testing purposes, replace numrdm with '100' + icsdsw(ix) = numrdm(i+isc-1 + (j+jsc-2)*cnx) + icsdlw(ix) = numrdm(i+isc-1 + (j+jsc-2)*cnx + cnx*cny) enddo -!$OMP end do + endif ! isubc_lw and isubc_sw - if (Model%imp_physics == 99) then - if (Model%kdt == 1) then -!$OMP do schedule (dynamic,1) - do nb = 1,nblks - Data(nb)%Tbd%phy_f3d(:,:,1) = Data(nb)%Statein%tgrs - Data(nb)%Tbd%phy_f3d(:,:,2) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) - Data(nb)%Tbd%phy_f3d(:,:,3) = Data(nb)%Statein%tgrs - Data(nb)%Tbd%phy_f3d(:,:,4) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) - Data(nb)%Tbd%phy_f2d(:,1) = Data(nb)%Statein%prsi(:,1) - Data(nb)%Tbd%phy_f2d(:,2) = Data(nb)%Statein%prsi(:,1) - enddo -!$OMP end do + if (imp_physics == imp_physics_zhao_carr) then + if (kdt == 1) then + t_2delt = t + t_1delt = t + qv_2delt = qv + qv_1delt = qv + ps_2delt = ps + ps_1delt = ps endif endif -!$OMP end parallel - endif - end subroutine GFS_rad_time_vary_run + end subroutine GFS_rad_time_vary_timestep_init !> @} - - subroutine GFS_rad_time_vary_finalize() - end subroutine GFS_rad_time_vary_finalize end module GFS_rad_time_vary diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 8ac28be30..4c8f8362c 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -5,32 +5,218 @@ ######################################################################## [ccpp-arg-table] - name = GFS_rad_time_vary_run + name = GFS_rad_time_vary_timestep_init type = scheme -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT +[lslwr] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[isubc_lw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in + optional = F +[isubc_sw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag dimensions = () - type = GFS_control_type + type = integer + intent = in + optional = F +[icsdsw] + standard_name = seed_random_numbers_sw + long_name = random seeds for sub-column cloud generators sw + units = none + dimensions = (horizontal_dimension) + type = integer intent = inout optional = F -[Data] - standard_name = GFS_data_type_instance_all_blocks - long_name = Fortran DDT containing FV3-GFS data - units = DDT - dimensions = (ccpp_block_number) - type = GFS_data_type +[icsdlw] + standard_name = seed_random_numbers_lw + long_name = random seeds for sub-column cloud generators lw + units = none + dimensions = (horizontal_dimension) + type = integer intent = inout optional = F -[nthrds] - standard_name = omp_threads - long_name = number of OpenMP threads available for physics schemes +[cnx] + standard_name = number_of_points_in_x_direction_for_this_cubed_sphere_face + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in + optional = F +[cny] + standard_name = number_of_points_in_y_direction_for_this_cubed_sphere_face + long_name = number of points in y direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in + optional = F +[isc] + standard_name = starting_x_index_for_this_MPI_rank + long_name = starting index in the x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in + optional = F +[jsc] + standard_name = starting_y_index_for_this_MPI_rank + long_name = starting index in the y direction for this MPI rank units = count dimensions = () type = integer intent = in optional = F +[imap] + standard_name = map_of_block_column_number_to_global_i_index + long_name = map of local index ix to global index i for this block + units = none + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[jmap] + standard_name = map_of_block_column_number_to_global_j_index + long_name = map of local index ix to global index j for this block + units = none + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[sec] + standard_name = seconds_elapsed_since_model_initialization + long_name = seconds elapsed since model initialization + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_zhao_carr] + standard_name = flag_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[ps_2delt] + standard_name = surface_air_pressure_two_timesteps_back + long_name = surface air pressure two timesteps back + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ps_1delt] + standard_name = surface_air_pressure_at_previous_timestep + long_name = surface air pressure at previous timestep + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[t_2delt] + standard_name = air_temperature_two_timesteps_back + long_name = air temperature two timesteps back + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[t_1delt] + standard_name = water_vapor_specific_humidity_two_timesteps_back + long_name = water vapor specific humidity two timesteps back + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qv_2delt] + standard_name = air_temperature_at_previous_timestep + long_name = air temperature at previous timestep + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qv_1delt] + standard_name = water_vapor_specific_humidity_at_previous_timestep + long_name = water vapor specific humidity at previous timestep + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[t] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qv] + standard_name = water_vapor_specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = air_pressure_at_lowest_model_interface + long_name = air pressure at lowest model interface + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 2c18ab1e0..920b6465e 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -14,7 +14,7 @@ module GFS_rrtmg_setup implicit none - public GFS_rrtmg_setup_init, GFS_rrtmg_setup_run, GFS_rrtmg_setup_finalize + public GFS_rrtmg_setup_init, GFS_rrtmg_setup_timestep_init, GFS_rrtmg_setup_finalize private @@ -320,10 +320,10 @@ subroutine GFS_rrtmg_setup_init ( & end subroutine GFS_rrtmg_setup_init -!> \section arg_table_GFS_rrtmg_setup_run Argument Table -!! \htmlinclude GFS_rrtmg_setup_run.html +!> \section arg_table_GFS_rrtmg_setup_timestep_init Argument Table +!! \htmlinclude GFS_rrtmg_setup_timestep_init.html !! - subroutine GFS_rrtmg_setup_run ( & + subroutine GFS_rrtmg_setup_timestep_init ( & idate, jdate, deltsw, deltim, lsswr, me, & slag, sdec, cdec, solcon, errmsg, errflg) @@ -345,7 +345,7 @@ subroutine GFS_rrtmg_setup_run ( & ! Check initialization state if (.not.is_initialized) then - write(errmsg, fmt='((a))') 'GFS_rrtmg_setup_run called before GFS_rrtmg_setup_init' + write(errmsg, fmt='((a))') 'GFS_rrtmg_setup_timestep_init called before GFS_rrtmg_setup_init' errflg = 1 return end if @@ -357,7 +357,7 @@ subroutine GFS_rrtmg_setup_run ( & call radupdate(idate,jdate,deltsw,deltim,lsswr,me, & slag,sdec,cdec,solcon) - end subroutine GFS_rrtmg_setup_run + end subroutine GFS_rrtmg_setup_timestep_init !> \section arg_table_GFS_rrtmg_setup_finalize Argument Table !! \htmlinclude GFS_rrtmg_setup_finalize.html @@ -523,12 +523,14 @@ subroutine radinit( si, NLAY, imp_physics, me ) !> -# Set up control variables and external module variables in !! module physparam #if 0 + ! DH* WHAT IS THIS? ! GFS_radiation_driver.F90 may in the future initialize air/ground ! temperature differently; however, this is not used at the moment ! and as such we avoid the difficulty of dealing with exchanging ! itsfc between GFS_rrtmg_setup and a yet-to-be-created/-used ! interstitial routine (or GFS_radiation_driver.F90) itsfc = iemsflg / 10 ! sfc air/ground temp control + ! *DH #endif loz1st = (ioznflg == 0) ! first-time clim ozone data read flag month0 = 0 diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index b8d94db6c..cfd6e6e9e 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -255,7 +255,7 @@ ######################################################################## [ccpp-arg-table] - name = GFS_rrtmg_setup_run + name = GFS_rrtmg_setup_timestep_init type = scheme [idate] standard_name = date_and_time_at_model_initialization diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 551f0e600..f9b33ec8c 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -14,23 +14,43 @@ end subroutine GFS_suite_interstitial_rad_reset_finalize !> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table !! \htmlinclude GFS_suite_interstitial_rad_reset_run.html !! - subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) + subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Diag, Model, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type,GFS_interstitial_type + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_diag_type, GFS_interstitial_type implicit none ! interface variables type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_diag_type), intent(inout) :: Diag type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind_phys) :: sec_zero + integer :: kdt_rad errmsg = '' errflg = 0 call Interstitial%rad_reset(Model) + !--- determine if radiation diagnostics buckets need to be cleared + sec_zero = nint(Model%fhzero*con_hr) + if (sec_zero >= nint(max(Model%fhswr,Model%fhlwr))) then + if (mod(Model%kdt,Model%nszero) == 1) then + call Diag%rad_zero(Model) + endif + else + kdt_rad = nint(min(Model%fhswr,Model%fhlwr)/Model%dtp) + if (mod(Model%kdt,kdt_rad) == 1) then + call Diag%rad_zero(Model) + endif + endif + end subroutine GFS_suite_interstitial_rad_reset_run end module GFS_suite_interstitial_rad_reset @@ -49,23 +69,30 @@ end subroutine GFS_suite_interstitial_phys_reset_finalize !> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table !! \htmlinclude GFS_suite_interstitial_phys_reset_run.html !! - subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) + subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Diag, Model, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_diag_type, GFS_interstitial_type implicit none ! interface variables type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_diag_type), intent(inout) :: Diag type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 call Interstitial%phys_reset(Model) + !--- determine if physics diagnostics buckets need to be cleared + if (mod(Model%kdt,Model%nszero) == 1) then + call Diag%phys_zero(Model) + endif + end subroutine GFS_suite_interstitial_phys_reset_run end module GFS_suite_interstitial_phys_reset diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index b27884f9a..b290a5723 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -15,6 +15,14 @@ type = GFS_interstitial_type intent = inout optional = F +[Diag] + standard_name = GFS_diag_type_instance + long_name = derived type GFS_diag_type in FV3 + units = DDT + dimensions = () + type = GFS_diag_type + intent = inout + optional = F [Model] standard_name = GFS_control_type_instance long_name = Fortran DDT containing FV3-GFS model control parameters @@ -59,6 +67,14 @@ type = GFS_interstitial_type intent = inout optional = F +[Diag] + standard_name = GFS_diag_type_instance + long_name = derived type GFS_diag_type in FV3 + units = DDT + dimensions = () + type = GFS_diag_type + intent = inout + optional = F [Model] standard_name = GFS_control_type_instance long_name = Fortran DDT containing FV3-GFS model control parameters diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 27e36b649..ba971fa67 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -9,7 +9,7 @@ module GFS_time_vary_pre private - public GFS_time_vary_pre_init, GFS_time_vary_pre_run, GFS_time_vary_pre_finalize + public GFS_time_vary_pre_init, GFS_time_vary_pre_timestep_init, GFS_time_vary_pre_finalize logical :: is_initialized = .false. @@ -62,12 +62,12 @@ subroutine GFS_time_vary_pre_finalize(errmsg, errflg) end subroutine GFS_time_vary_pre_finalize -!> \section arg_table_GFS_time_vary_pre_run Argument Table -!! \htmlinclude GFS_time_vary_pre_run.html +!> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table +!! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, & - nslwr, nhfrad, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, & - kdt, julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, & + nslwr, nhfrad, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, & + kdt, julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) use machine, only: kind_phys @@ -104,8 +104,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, ! Check initialization status if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called & - &before GFS_time_vary_pre_init" + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_timestep_init called before GFS_time_vary_pre_init" errflg = 1 return end if @@ -190,6 +189,6 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, print *,' solhr ', solhr endif - end subroutine GFS_time_vary_pre_run + end subroutine GFS_time_vary_pre_timestep_init end module GFS_time_vary_pre diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index e5e388a07..6266889aa 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -49,7 +49,7 @@ ######################################################################## [ccpp-arg-table] - name = GFS_time_vary_pre_run + name = GFS_time_vary_pre_timestep_init type = scheme [jdat] standard_name = forecast_date_and_time diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 8b3555826..f16b41b2b 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -2,175 +2,159 @@ !! This file repopulates specific time-varying surface properties for !! atmospheric forecast runs. +module gcycle_mod + + implicit none + + private + + public gcycle + +contains + !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, kice, idate, ialb, isot, ivegsrc, use_ufo, & + nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, frac_grid, & + smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, hice, fice, & + facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd,& + slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, imap, jmap) ! ! - USE MACHINE, only: kind_phys - USE PHYSCONS, only: PI => con_PI - USE GFS_typedefs, only: GFS_control_type, GFS_grid_type, & - GFS_sfcprop_type, GFS_cldprop_type + use machine, only: kind_phys implicit none - integer, intent(in) :: nblks, nthrds - type(GFS_control_type), intent(in) :: Model - type(GFS_grid_type), intent(in) :: Grid(nblks) - type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) - type(GFS_cldprop_type), intent(inout) :: Cldprop(nblks) - + integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & + tile_num, nlunit, lsoil, kice + integer, intent(in) :: idate(:), ialb, isot, ivegsrc + character(len=*), intent(in) :: input_nml_file(:) + logical, intent(in) :: use_ufo, nst_anl, frac_grid + real(kind=kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), & + min_seaice, min_lakeice, & + xlat_d(:), xlon_d(:) + real(kind=kind_phys), intent(inout) :: smc(:,:), & + slc(:,:), & + stc(:,:), & + tiice(:,:), & + tg3(:), & + tref(:), & + tsfc(:), & + tsfco(:), & + tisfc(:), & + hice(:), & + fice(:), & + facsf(:), & + facwf(:), & + alvsf(:), & + alvwf(:), & + alnsf(:), & + alnwf(:), & + zorli(:), & + zorll(:), & + zorlo(:), & + weasd(:), & + slope(:), & + snoalb(:), & + canopy(:), & + vfrac(:), & + vtype(:), & + stype(:), & + shdmin(:), & + shdmax(:), & + snowd(:), & + cv(:), & + cvb(:), & + cvt(:), & + oro(:), & + oro_uf(:), & + slmsk(:) + + integer, intent(in) :: imap(:), jmap(:) ! ! Local variables ! --------------- - integer :: & - I_INDEX(Model%nx*Model%ny), & - J_INDEX(Model%nx*Model%ny) - - real(kind=kind_phys) :: & - RLA (Model%nx*Model%ny), & - RLO (Model%nx*Model%ny), & - SLMASK (Model%nx*Model%ny), & - OROG (Model%nx*Model%ny), & - OROG_UF (Model%nx*Model%ny), & - SLIFCS (Model%nx*Model%ny), & - TSFFCS (Model%nx*Model%ny), & - SNOFCS (Model%nx*Model%ny), & - ZORFCS (Model%nx*Model%ny), & - TG3FCS (Model%nx*Model%ny), & - CNPFCS (Model%nx*Model%ny), & - AISFCS (Model%nx*Model%ny), & -! F10MFCS(Model%nx*Model%ny), & - VEGFCS (Model%nx*Model%ny), & - VETFCS (Model%nx*Model%ny), & - SOTFCS (Model%nx*Model%ny), & - CVFCS (Model%nx*Model%ny), & - CVBFCS (Model%nx*Model%ny), & - CVTFCS (Model%nx*Model%ny), & - SWDFCS (Model%nx*Model%ny), & - SIHFCS (Model%nx*Model%ny), & - SICFCS (Model%nx*Model%ny), & - SITFCS (Model%nx*Model%ny), & - VMNFCS (Model%nx*Model%ny), & - VMXFCS (Model%nx*Model%ny), & - SLPFCS (Model%nx*Model%ny), & - 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) - - logical :: lake(Model%nx*Model%ny) - - character(len=6) :: tile_num_ch - real(kind=kind_phys), parameter :: pifac=180.0/pi - real(kind=kind_phys) :: sig1t, dt_warm - integer :: npts, len, nb, ix, jx, ls, ios, ll - logical :: exists + real(kind=kind_phys) :: & + SLMASK (nx*ny), & + TSFFCS (nx*ny), & + ZORFCS (nx*ny), & + AISFCS (nx*ny), & + ALFFC1 (nx*ny*2), & + ALBFC1 (nx*ny*4), & + SMCFC1 (nx*ny*lsoil), & + STCFC1 (nx*ny*lsoil), & + SLCFC1 (nx*ny*lsoil) + + logical :: lake(nx*ny) + character(len=6) :: tile_num_ch + real(kind=kind_phys) :: sig1t, dt_warm + integer :: npts, nb, ix, jx, ls, ios, ll + logical :: exists ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ! ! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' ! *,lonsinpe(0,1) - +! tile_num_ch = " " - if (Model%tile_num < 10) then - write(tile_num_ch, "(a4,i1)") "tile", Model%tile_num + if (tile_num < 10) then + write(tile_num_ch, "(a4,i1)") "tile", tile_num else - write(tile_num_ch, "(a4,i2)") "tile", Model%tile_num + write(tile_num_ch, "(a4,i2)") "tile", tile_num endif - - len = 0 - do jx = Model%jsc, (Model%jsc+Model%ny-1) - do ix = Model%isc, (Model%isc+Model%nx-1) - len = len + 1 - i_index(len) = ix - j_index(len) = jx - enddo - enddo - +! sig1t = 0.0_kind_phys - npts = Model%nx*Model%ny + npts = nx*ny ! - len = 0 - do nb = 1,nblks - do ix = 1,size(Grid(nb)%xlat,1) - len = len + 1 - RLA (len) = Grid(nb)%xlat (ix) * pifac - RLO (len) = Grid(nb)%xlon (ix) * pifac - OROG (len) = Sfcprop(nb)%oro (ix) - OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) - SLIFCS (len) = Sfcprop(nb)%slmsk (ix) - if ( Model%nstf_name(1) > 0 ) then - TSFFCS(len) = Sfcprop(nb)%tref (ix) - else - TSFFCS(len) = Sfcprop(nb)%tsfc (ix) - endif - SNOFCS (len) = Sfcprop(nb)%weasd (ix) - ZORFCS (len) = Sfcprop(nb)%zorll (ix) - if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then - ZORFCS (len) = Sfcprop(nb)%zorli (ix) - elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then - ZORFCS (len) = Sfcprop(nb)%zorlo (ix) - endif - TG3FCS (len) = Sfcprop(nb)%tg3 (ix) - CNPFCS (len) = Sfcprop(nb)%canopy (ix) -! F10MFCS (len) = Sfcprop(nb)%f10m (ix) - VEGFCS (len) = Sfcprop(nb)%vfrac (ix) - VETFCS (len) = Sfcprop(nb)%vtype (ix) - SOTFCS (len) = Sfcprop(nb)%stype (ix) - CVFCS (len) = Cldprop(nb)%cv (ix) - CVBFCS (len) = Cldprop(nb)%cvb (ix) - CVTFCS (len) = Cldprop(nb)%cvt (ix) - SWDFCS (len) = Sfcprop(nb)%snowd (ix) - SIHFCS (len) = Sfcprop(nb)%hice (ix) - SICFCS (len) = Sfcprop(nb)%fice (ix) - SITFCS (len) = Sfcprop(nb)%tisfc (ix) - VMNFCS (len) = Sfcprop(nb)%shdmin (ix) - VMXFCS (len) = Sfcprop(nb)%shdmax (ix) - SLPFCS (len) = Sfcprop(nb)%slope (ix) - ABSFCS (len) = Sfcprop(nb)%snoalb (ix) - - ALFFC1 (len ) = Sfcprop(nb)%facsf (ix) - ALFFC1 (len + npts) = Sfcprop(nb)%facwf (ix) - - ALBFC1 (len ) = Sfcprop(nb)%alvsf (ix) - ALBFC1 (len + npts ) = Sfcprop(nb)%alvwf (ix) - 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) - enddo - - IF (SLIFCS(len) < 0.1_kind_phys .OR. SLIFCS(len) > 1.5_kind_phys) THEN - SLMASK(len) = 0.0_kind_phys - ELSE - SLMASK(len) = 1.0_kind_phys - ENDIF - - IF (SLIFCS(len) > 1.99_kind_phys) THEN - AISFCS(len) = 1.0_kind_phys - ELSE - AISFCS(len) = 0.0_kind_phys - ENDIF - if (Sfcprop(nb)%lakefrac(ix) > 0.0_kind_phys) then - lake(len) = .true. - else - lake(len) = .false. - endif - -! if (Model%me .eq. 0) -! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) - ENDDO !-----END BLOCK SIZE LOOP------------------------------ - ENDDO !-----END BLOCK LOOP------------------------------- - -! check -! call mymaxmin(slifcs,len,len,1,'slifcs') -! call mymaxmin(slmask,len,len,1,'slmsk') + if ( nsst > 0 ) then + TSFFCS = tref + else + TSFFCS = tsfc + end if +! + do ix=1,npts + ZORFCS(ix) = zorll (ix) + if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then + ZORFCS(ix) = zorli (ix) + elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then + ZORFCS(ix) = zorlo (ix) + endif + ! DH* Why not 1.9 as for ZORFCS? + IF (slmsk(ix) > 1.99_kind_phys) THEN + AISFCS(ix) = 1.0_kind_phys + ELSE + AISFCS(ix) = 0.0_kind_phys + ENDIF + ! + ALFFC1(ix ) = facsf(ix) + ALFFC1(ix + npts ) = facwf(ix) + ! + ALBFC1(ix ) = alvsf(ix) + ALBFC1(ix + npts ) = alvwf(ix) + ALBFC1(ix + npts*2) = alnsf(ix) + ALBFC1(ix + npts*3) = alnwf(ix) + ! + do ls = 1,lsoil + ll = ix + (ls-1)*npts + SMCFC1(ll) = smc(ix,ls) + STCFC1(ll) = stc(ix,ls) + SLCFC1(ll) = slc(ix,ls) + enddo + ! + IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN + SLMASK(ix) = 0.0_kind_phys + ELSE + SLMASK(ix) = 1.0_kind_phys + ENDIF + ! + if (lakefrac(ix) > 0.0_kind_phys) then + lake(ix) = .true. + else + lake(ix) = .false. + endif + end do ! #ifndef INTERNAL_FILE_NML inquire (file=trim(Model%fn_nml),exist=exists) @@ -182,90 +166,59 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) rewind (Model%nlunit) endif #endif - CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & - Model%idate(4), Model%idate(2), & - Model%idate(3), Model%idate(1), & - Model%phour, RLA, RLO, SLMASK, & -! Model%fhour, RLA, RLO, SLMASK, & - OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & - SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & - VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, & - SNOFCS, ZORFCS, ALBFC1, TG3FCS, CNPFCS, & - SMCFC1, STCFC1, SLIFCS, AISFCS, & - VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & - CVBFCS, CVTFCS, Model%me, nthrds, & - Model%nlunit, size(Model%input_nml_file), & - Model%input_nml_file, & - lake, Model%min_lakeice, Model%min_seaice, & - Model%ialb, Model%isot, Model%ivegsrc, & - trim(tile_num_ch), i_index, j_index) + CALL SFCCYCLE (9998, npts, lsoil, sig1t, fhcyc, & + idate(4), idate(2), idate(3), idate(1), & + phour, xlat_d, xlon_d, slmask, & + oro, oro_uf, use_ufo, nst_anl, & + hice, fice, tisfc, snowd, slcfc1, & + shdmin, shdmax, slope, snoalb, tsffcs, & + weasd, zorfcs, albfc1, tg3, canopy, & + smcfc1, stcfc1, slmsk, aisfcs, & + vfrac, vtype, stype, alffc1, cv, & + cvb, cvt, me, nthrds, & + nlunit, size(input_nml_file), input_nml_file,& + lake, min_lakeice, min_seaice, & + ialb, isot, ivegsrc, & + trim(tile_num_ch), imap, jmap) #ifndef INTERNAL_FILE_NML close (Model%nlunit) #endif - - len = 0 - do nb = 1,nblks - do ix = 1,size(Grid(nb)%xlat,1) - len = len + 1 - Sfcprop(nb)%slmsk (ix) = SLIFCS (len) - if ( Model%nstf_name(1) > 0 ) then - Sfcprop(nb)%tref(ix) = TSFFCS (len) -! if ( Model%nstf_name(2) == 0 ) then -! dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & -! / Sfcprop(nb)%xz(ix) -! Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & -! + dt_warm - Sfcprop(nb)%dt_cool(ix) -! endif - else - Sfcprop(nb)%tsfc(ix) = TSFFCS (len) - Sfcprop(nb)%tsfco(ix) = TSFFCS (len) - endif - Sfcprop(nb)%weasd (ix) = SNOFCS (len) - Sfcprop(nb)%zorll (ix) = ZORFCS (len) - if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then - Sfcprop(nb)%zorli(ix) = ZORFCS (len) - elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then - Sfcprop(nb)%zorlo(ix) = ZORFCS (len) - endif - Sfcprop(nb)%tg3 (ix) = TG3FCS (len) - Sfcprop(nb)%canopy (ix) = CNPFCS (len) -! Sfcprop(nb)%f10m (ix) = F10MFCS (len) - Sfcprop(nb)%vfrac (ix) = VEGFCS (len) - Sfcprop(nb)%vtype (ix) = VETFCS (len) - Sfcprop(nb)%stype (ix) = SOTFCS (len) - Cldprop(nb)%cv (ix) = CVFCS (len) - Cldprop(nb)%cvb (ix) = CVBFCS (len) - Cldprop(nb)%cvt (ix) = CVTFCS (len) - Sfcprop(nb)%snowd (ix) = SWDFCS (len) - Sfcprop(nb)%hice (ix) = SIHFCS (len) - Sfcprop(nb)%fice (ix) = SICFCS (len) - Sfcprop(nb)%tisfc (ix) = SITFCS (len) - Sfcprop(nb)%shdmin (ix) = VMNFCS (len) - Sfcprop(nb)%shdmax (ix) = VMXFCS (len) - Sfcprop(nb)%slope (ix) = SLPFCS (len) - Sfcprop(nb)%snoalb (ix) = ABSFCS (len) - - Sfcprop(nb)%facsf (ix) = ALFFC1 (len ) - Sfcprop(nb)%facwf (ix) = ALFFC1 (len + npts) - - Sfcprop(nb)%alvsf (ix) = ALBFC1 (len ) - 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 - 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 (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) - enddo - ENDDO !-----END BLOCK SIZE LOOP-------------------------- - ENDDO !-----END BLOCK LOOP------------------------------- - -! check -! call mymaxmin(slifcs,len,len,1,'slifcs') +! + if ( nsst > 0 ) then + tref = TSFFCS + else + tsfc = TSFFCS + tsfco = TSFFCS + end if +! + do ix=1,npts + zorll(ix) = ZORFCS(ix) + if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then + zorli(ix) = ZORFCS(ix) + elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then + zorlo(ix) = ZORFCS(ix) + endif + ! + facsf(ix) = ALFFC1(ix ) + facwf(ix) = ALFFC1(ix + npts ) + ! + alvsf(ix) = ALBFC1(ix ) + alvwf(ix) = ALBFC1(ix + npts ) + alnsf(ix) = ALBFC1(ix + npts*2) + alnwf(ix) = ALBFC1(ix + npts*3) + ! + do ls = 1,lsoil + ll = ix + (ls-1)*npts + smc(ix,ls) = SMCFC1(ll) + stc(ix,ls) = STCFC1(ll) + slc(ix,ls) = SLCFC1(ll) + if (ls<=kice) tiice(ix,ls) = STCFC1(ll) + enddo + enddo ! ! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour - +! RETURN END + +end module gcycle_mod diff --git a/physics/h2o_def.f b/physics/h2o_def.f index d1d6407dd..72748a613 100644 --- a/physics/h2o_def.f +++ b/physics/h2o_def.f @@ -4,6 +4,11 @@ !>\ingroup mod_GFS_phys_time_vary !! This module defines arrays in H2O scheme. module h2o_def + +!> \section arg_table_h2o_def +!! \htmlinclude h2o_def.html +!! + use machine , only : kind_phys implicit none diff --git a/physics/h2o_def.meta b/physics/h2o_def.meta new file mode 100644 index 000000000..21f3b903f --- /dev/null +++ b/physics/h2o_def.meta @@ -0,0 +1,29 @@ +[ccpp-table-properties] + name = h2o_def + type = module + dependencies = machine.F + +[ccpp-arg-table] + name = h2o_def + type = module + +[levh2o] + standard_name = vertical_dimension_of_h2o_forcing_data + long_name = number of vertical layers in h2o forcing data + units = count + dimensions = () + type = integer +[h2o_coeff] + standard_name = number_of_coefficients_in_h2o_forcing_data + long_name = number of coefficients in h2o forcing data + units = index + dimensions = () + type = integer +[h2o_pres] + standard_name = natural_log_of_h2o_forcing_data_pressure_levels + long_name = natural log of h2o forcing data pressure levels + units = log(Pa) + dimensions = (vertical_dimension_of_h2o_forcing_data) + type = real + kind = kind_phys + active = (flag_for_stratospheric_water_vapor_physics) \ No newline at end of file diff --git a/physics/ozne_def.f b/physics/ozne_def.f index 3f7fddb8b..8f3af6240 100644 --- a/physics/ozne_def.f +++ b/physics/ozne_def.f @@ -4,6 +4,11 @@ !>\ingroup mod_GFS_phys_time_vary !! This module defines arrays in Ozone scheme. module ozne_def + +!> \section arg_table_ozne_def +!! \htmlinclude ozne_def.html +!! + use machine , only : kind_phys implicit none diff --git a/physics/ozne_def.meta b/physics/ozne_def.meta new file mode 100644 index 000000000..27698eec6 --- /dev/null +++ b/physics/ozne_def.meta @@ -0,0 +1,29 @@ +[ccpp-table-properties] + name = ozne_def + type = module + dependencies = machine.F + +[ccpp-arg-table] + name = ozne_def + type = module + +[levozp] + standard_name = vertical_dimension_of_ozone_forcing_data + long_name = number of vertical layers in ozone forcing data + units = count + dimensions = () + type = integer +[oz_coeff] + standard_name = number_of_coefficients_in_ozone_forcing_data + long_name = number of coefficients in ozone forcing data + units = index + dimensions = () + type = integer +[oz_pres] + standard_name = natural_log_of_ozone_forcing_data_pressure_levels + long_name = natural log of ozone forcing data pressure levels + units = log(Pa) + dimensions = (vertical_dimension_of_ozone_forcing_data) + type = real + kind = kind_phys + active = (index_for_ozone>0) From 04ee898cfabb6af07087c6ea9a3108f758ac668a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 18 Dec 2020 08:07:30 -0700 Subject: [PATCH 35/67] Updates to physics/GFS_phys_time_vary.fv3.* and physics/gcycle.F90 following the merge of NCAR master --- physics/GFS_phys_time_vary.fv3.F90 | 33 ++++++++++++++------------- physics/GFS_phys_time_vary.fv3.meta | 35 +++++++++++++++++++++++++++++ physics/gcycle.F90 | 18 +++++++++------ 3 files changed, 63 insertions(+), 23 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 4043b9090..71e0dbf3e 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -264,11 +264,11 @@ subroutine GFS_phys_time_vary_timestep_init ( jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & - imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, kice, & - ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & - lakefrac, min_seaice, min_lakeice, smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, & - hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd, & - slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & + imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, lsoil_lsm,& + kice, ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & + lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & + tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & + zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, errmsg, errflg) implicit none @@ -294,15 +294,15 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: seed0 real(kind_phys), intent(out) :: rann(:,:) ! For gcycle only - integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, kice - integer, intent(in) :: ialb, isot, ivegsrc + integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil + integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) - ! - real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), tiice(:,:), tg3(:), & - tref(:), tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & + real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & + tslb(:,:), tiice(:,:), tg3(:), tref(:), & + tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & @@ -405,12 +405,13 @@ subroutine GFS_phys_time_vary_timestep_init ( if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, kice, idate, ialb, isot, ivegsrc, use_ufo, & - nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, frac_grid, & - smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, hice, fice, & - facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd,& - slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, imap, jmap) + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + xlat_d, xlon_d, slmsk, imap, jmap) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index e78a13e4b..0258e084f 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -847,6 +847,14 @@ type = integer intent = in optional = F +[lsoil_lsm] + 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 [kice] standard_name = ice_vertical_dimension long_name = vertical loop extent for ice levels, start at 1 @@ -984,6 +992,33 @@ 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_loop_extent,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + 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_loop_extent,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_loop_extent,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F [tiice] standard_name = internal_ice_temperature long_name = sea ice internal temperature diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 6aaab8836..558a65860 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -16,19 +16,20 @@ module gcycle_mod !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, kice, idate, ialb, isot, ivegsrc, use_ufo, & - nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, frac_grid, & - smc, slc, stc, tiice, tg3, tref, tsfc, tsfco, tisfc, hice, fice, & - facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, zorlo, weasd,& - slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, imap, jmap) + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + xlat_d, xlon_d, slmsk, imap, jmap) ! ! use machine, only: kind_phys implicit none integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & - tile_num, nlunit, lsoil, kice + tile_num, nlunit, lsoil, lsoil_lsm, kice integer, intent(in) :: idate(:), ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid @@ -38,6 +39,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & real(kind=kind_phys), intent(inout) :: smc(:,:), & slc(:,:), & stc(:,:), & + smois(:,:), & + sh2o(:,:), & + tslb(:,:), & tiice(:,:), & tg3(:), & tref(:), & From 5ce1183c08507eb94e5a84e24b214686d40afca1 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 18 Dec 2020 19:45:33 +0000 Subject: [PATCH 36/67] Add do_mynnedmf to GP to GFDL-MP coupling. Bound particle size for use in GP cloud-optics. --- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 61 ++++++++++++++++++++---------- physics/GFS_rrtmgp_gfdlmp_pre.meta | 56 +++++++++++++++++++++------ 2 files changed, 86 insertions(+), 31 deletions(-) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index 31c67d62f..16844304b 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -6,16 +6,19 @@ module GFS_rrtmgp_gfdlmp_pre use machine, only: kind_phys use rrtmgp_aux, only: check_error_msg use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + use rrtmgp_lw_cloud_optics, only: radliq_lwr, radliq_upr, radice_lwr, radice_upr ! Parameters real(kind_phys), parameter :: & reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) - resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) - reice_min = 10.0, & ! Minimum ice size allowed by scheme - reice_max = 150.0 ! Maximum ice size allowed by scheme - + resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) + reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme + reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme + ! NOTE: When using RRTMGP cloud-optics, the min/max particle size allowed are imported + ! from initialization. + public GFS_rrtmgp_gfdlmp_pre_init, GFS_rrtmgp_gfdlmp_pre_run, GFS_rrtmgp_gfdlmp_pre_finalize contains @@ -30,9 +33,9 @@ end subroutine GFS_rrtmgp_gfdlmp_pre_init !! \htmlinclude GFS_rrtmgp_gfdlmp_pre_run.html !! subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, doSWrad, doLWrad, effr_in, & - p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & - effrin_cldsnow, tracer, con_g, con_rd, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, doSWrad, doLWrad, effr_in, kdt, & + do_mynnedmf, p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & + effrin_cldsnow, tracer, con_g, con_rd, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, errmsg, errflg) implicit none @@ -48,11 +51,15 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld i_cldrain, & ! Index into tracer array for cloud rain. i_cldsnow, & ! Index into tracer array for cloud snow. i_cldgrpl, & ! Index into tracer array for cloud groupel. - i_cldtot ! Index into tracer array for cloud total amount. + i_cldtot, & ! Index into tracer array for cloud total amount. + kdt ! Current forecast iteration logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad, & ! Call LW radiation - effr_in ! Provide hydrometeor radii from macrophysics? + effr_in, & ! Provide hydrometeor radii from macrophysics? + do_mynnedmf, & ! Flag to activate MYNN-EDMF + doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) + doGP_cldoptics_PADE ! (PADE approximation) real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd ! Physical constant: gas-constant for dry air @@ -69,7 +76,7 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld tracer ! Cloud condensate amount in layer by type () ! Outputs - real(kind_phys), dimension(nCol,nLev),intent(out) :: & + real(kind_phys), dimension(nCol,nLev),intent(inout) :: & cld_frac, & ! Total cloud fraction cld_lwp, & ! Cloud liquid water path cld_reliq, & ! Cloud liquid effective radius @@ -106,14 +113,10 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld return endif - ! Initialize outputs - cld_lwp(:,:) = 0.0 + ! Initialize outputs cld_reliq(:,:) = reliq_def - cld_iwp(:,:) = 0.0 cld_reice(:,:) = reice_def - cld_rwp(:,:) = 0.0 cld_rerain(:,:) = rerain_def - cld_swp(:,:) = 0.0 cld_resnow(:,:) = resnow_def ! #################################################################################### @@ -137,8 +140,8 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) enddo - enddo - + enddo + ! Particle size do iLay = 1, nLev do iCol = 1, nCol @@ -151,12 +154,32 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld endif enddo enddo + + ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from + ! 2.5 - 21.5 microns for liquid clouds, + ! 10 - 180 microns for ice-clouds + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + where(cld_reliq .lt. radliq_lwr) cld_reliq = radliq_lwr + where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr + where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr + where(cld_reice .gt. radice_upr) cld_reice = radice_upr + endif ! Cloud-fraction - cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + if (do_mynnedmf .and. kdt .gt. 1) then + do iLay = 1, nLev + do iCol = 1, nCol + if (tracer(iCol,iLay,i_cldrain) > 1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + enddo + enddo + else + cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + endif ! Precipitation fraction (Hack. For now use cloud-fraction) - precip_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) end subroutine GFS_rrtmgp_gfdlmp_pre_run diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 5894d9f5d..19d09cd79 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_gfdlmp_pre type = scheme - dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90 + dependencies = rrtmgp_aux.F90, radiation_cloud_overlap.F90, rrtmgp_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] @@ -62,7 +62,39 @@ dimensions = () type = logical intent = in - optional = F + optional = F +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in + optional = F +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_mynnedmf] + standard_name = do_mynnedmf + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F [i_cldliq] standard_name = index_for_liquid_cloud_condensate long_name = tracer index for cloud condensate (or liquid water) @@ -208,7 +240,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_lwp] standard_name = cloud_liquid_water_path @@ -217,7 +249,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_reliq] standard_name = mean_effective_radius_for_liquid_cloud @@ -226,7 +258,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_iwp] standard_name = cloud_ice_water_path @@ -235,7 +267,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_reice] standard_name = mean_effective_radius_for_ice_cloud @@ -244,7 +276,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_swp] standard_name = cloud_snow_water_path @@ -253,7 +285,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_resnow] standard_name = mean_effective_radius_for_snow_flake @@ -262,7 +294,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_rwp] standard_name = cloud_rain_water_path @@ -271,7 +303,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [cld_rerain] standard_name = mean_effective_radius_for_rain_drop @@ -280,7 +312,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [precip_frac] standard_name = precipitation_fraction_by_layer @@ -289,7 +321,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [errmsg] standard_name = ccpp_error_message From 08bd983879df9c3e7d491912190170d6dcfb0c56 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 29 Dec 2020 08:53:34 -0700 Subject: [PATCH 37/67] Bugfixes for OpenMP and Zhao-Carr MP in physics/GFS_phys_time_vary.fv3.{F90,meta} --- physics/GFS_phys_time_vary.fv3.F90 | 8 ++++++-- physics/GFS_rad_time_vary.fv3.meta | 12 ++++++------ 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 71e0dbf3e..1c3f2cf45 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -92,7 +92,7 @@ subroutine GFS_phys_time_vary_init ( if (is_initialized) return !$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared (me,master,ntoz,h2o_phys,im) & +!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,idate) & !$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & !$OMP shared (levozp,oz_coeff,oz_pres,ozpl) & !$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & @@ -177,7 +177,11 @@ subroutine GFS_phys_time_vary_init ( ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP barrier +!$OMP end sections + +! Need an OpenMP barrier here (implicit in "end sections") + +!$OMP sections !$OMP section !> - Call setindxoz() to initialize ozone data diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 4c8f8362c..ffe33810c 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -164,18 +164,18 @@ intent = inout optional = F [t_1delt] - standard_name = water_vapor_specific_humidity_two_timesteps_back - long_name = water vapor specific humidity two timesteps back - units = kg kg-1 + standard_name = air_temperature_at_previous_timestep + long_name = air temperature at previous timestep + units = K dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qv_2delt] - standard_name = air_temperature_at_previous_timestep - long_name = air temperature at previous timestep - units = K + standard_name = water_vapor_specific_humidity_two_timesteps_back + long_name = water vapor specific humidity two timesteps back + units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys From 7107b4970af1aa39d4a908030767b5bbaab51efe Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 29 Dec 2020 09:38:59 -0700 Subject: [PATCH 38/67] Remove unused num_p2d = array_dimension_of_2d_arrays_for_microphysics from physics/GFS_rrtmg_setup.{F90,meta} --- physics/GFS_rrtmg_setup.F90 | 15 +++++++-------- physics/GFS_rrtmg_setup.meta | 8 -------- 2 files changed, 7 insertions(+), 16 deletions(-) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 920b6465e..85ffe7d67 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -43,13 +43,13 @@ module GFS_rrtmg_setup !! \section arg_table_GFS_rrtmg_setup_init Argument Table !! \htmlinclude GFS_rrtmg_setup_init.html !! - subroutine GFS_rrtmg_setup_init ( & - si, levr, ictm, isol, ico2, iaer, ialb, iems, ntcw, num_p2d, & - num_p3d, npdf3d, ntoz, iovr, isubc_sw, isubc_lw, & - icliq_sw, crick_proof, ccnorm, & - imp_physics, & - norad_precip, idate, iflip, & - im, faerlw, faersw, aerodp, & ! for consistency checks + subroutine GFS_rrtmg_setup_init ( & + si, levr, ictm, isol, ico2, iaer, ialb, iems, ntcw, & + num_p3d, npdf3d, ntoz, iovr, isubc_sw, isubc_lw, & + icliq_sw, crick_proof, ccnorm, & + imp_physics, & + norad_precip, idate, iflip, & + im, faerlw, faersw, aerodp, & ! for consistency checks me, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! @@ -174,7 +174,6 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: ialb integer, intent(in) :: iems integer, intent(in) :: ntcw - integer, intent(in) :: num_p2d integer, intent(in) :: num_p3d integer, intent(in) :: npdf3d integer, intent(in) :: ntoz diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index cfd6e6e9e..e0019b4c5 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -80,14 +80,6 @@ type = integer intent = in optional = F -[num_p2d] - standard_name = array_dimension_of_2d_arrays_for_microphysics - long_name = number of 2D arrays needed for microphysics - units = count - dimensions = () - type = integer - intent = in - optional = F [num_p3d] standard_name = array_dimension_of_3d_arrays_for_microphysics long_name = number of 3D arrays needed for microphysics From 1eebface86c4a134e742bf15c2ce1de3eb6462f3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Dec 2020 08:19:26 -0700 Subject: [PATCH 39/67] Remove reset of diagnostic buckets from GFS_suite_interstitial.{F90,meta} --- physics/GFS_suite_interstitial.F90 | 33 ++++------------------------- physics/GFS_suite_interstitial.meta | 16 -------------- 2 files changed, 4 insertions(+), 45 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index eb7f9789f..c465f74e7 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -14,43 +14,24 @@ end subroutine GFS_suite_interstitial_rad_reset_finalize !> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table !! \htmlinclude GFS_suite_interstitial_rad_reset_run.html !! - subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Diag, Model, errmsg, errflg) + subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_diag_type, GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type implicit none ! interface variables type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_diag_type), intent(inout) :: Diag type(GFS_control_type), intent(in) :: Model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! local variables - real(kind_phys), parameter :: con_hr = 3600.0_kind_phys - real(kind_phys) :: sec_zero - integer :: kdt_rad - errmsg = '' errflg = 0 call Interstitial%rad_reset(Model) - !--- determine if radiation diagnostics buckets need to be cleared - sec_zero = nint(Model%fhzero*con_hr) - if (sec_zero >= nint(max(Model%fhswr,Model%fhlwr))) then - if (mod(Model%kdt,Model%nszero) == 1) then - call Diag%rad_zero(Model) - endif - else - kdt_rad = nint(min(Model%fhswr,Model%fhlwr)/Model%dtp) - if (mod(Model%kdt,kdt_rad) == 1) then - call Diag%rad_zero(Model) - endif - endif - end subroutine GFS_suite_interstitial_rad_reset_run end module GFS_suite_interstitial_rad_reset @@ -69,16 +50,15 @@ end subroutine GFS_suite_interstitial_phys_reset_finalize !> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table !! \htmlinclude GFS_suite_interstitial_phys_reset_run.html !! - subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Diag, Model, errmsg, errflg) + subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_diag_type, GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type implicit none ! interface variables type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_diag_type), intent(inout) :: Diag type(GFS_control_type), intent(in) :: Model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -88,11 +68,6 @@ subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Diag, Model, err call Interstitial%phys_reset(Model) - !--- determine if physics diagnostics buckets need to be cleared - if (mod(Model%kdt,Model%nszero) == 1) then - call Diag%phys_zero(Model) - endif - end subroutine GFS_suite_interstitial_phys_reset_run end module GFS_suite_interstitial_phys_reset diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 89b727c9b..fdf1716f1 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -15,14 +15,6 @@ type = GFS_interstitial_type intent = inout optional = F -[Diag] - standard_name = GFS_diag_type_instance - long_name = derived type GFS_diag_type in FV3 - units = DDT - dimensions = () - type = GFS_diag_type - intent = inout - optional = F [Model] standard_name = GFS_control_type_instance long_name = Fortran DDT containing FV3-GFS model control parameters @@ -67,14 +59,6 @@ type = GFS_interstitial_type intent = inout optional = F -[Diag] - standard_name = GFS_diag_type_instance - long_name = derived type GFS_diag_type in FV3 - units = DDT - dimensions = () - type = GFS_diag_type - intent = inout - optional = F [Model] standard_name = GFS_control_type_instance long_name = Fortran DDT containing FV3-GFS model control parameters From e11fb718bd8ad5f2ad111347baeac3b40417e0bf Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Dec 2020 15:34:16 -0700 Subject: [PATCH 40/67] Bugfix in physics/GFS_phys_time_vary.fv3.{F90,meta}, correct intent of variabale 'rann' --- physics/GFS_phys_time_vary.fv3.F90 | 2 +- physics/GFS_phys_time_vary.fv3.meta | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 1c3f2cf45..8f0bc50d9 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -296,7 +296,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: imap(:), jmap(:) real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 - real(kind_phys), intent(out) :: rann(:,:) + real(kind_phys), intent(inout) :: rann(:,:) ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 0258e084f..7ae6b4948 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -789,7 +789,7 @@ dimensions = (horizontal_dimension,array_dimension_of_random_number) type = real kind = kind_phys - intent = out + intent = inout optional = F [nthrds] standard_name = omp_threads From f18c4ef6a46c479ac8d2cc725bba77e9b88bbff0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Dec 2020 15:35:57 -0700 Subject: [PATCH 41/67] Bugfix in physics/GFS_rrtmgp_setup.{F90,meta}, rename _run to _timestep_init --- physics/GFS_rrtmgp_setup.F90 | 19 ++++++++++--------- physics/GFS_rrtmgp_setup.meta | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index a32f96ccf..308456e06 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -13,7 +13,7 @@ module GFS_rrtmgp_setup iaermdl, ialbflg, iemsflg, ivflip implicit none - public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_run, GFS_rrtmgp_setup_finalize + public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize ! Version tag and last revision date character(40), parameter :: & @@ -27,7 +27,7 @@ module GFS_rrtmgp_setup logical :: & is_initialized = .false. ! Control flag for the first time of reading climatological ozone data - ! (set/reset in subroutines GFS_rrtmgp_setup_init/GFS_rrtmgp_setuup_run, it is used only if + ! (set/reset in subroutines GFS_rrtmgp_setup_init/GFS_rrtmgp_setup_timestep_init, it is used only if ! the control parameter ioznflg=0) logical :: loz1st = .true. @@ -151,13 +151,13 @@ subroutine GFS_rrtmgp_setup_init(imp_physics, imp_physics_fer_hires, imp_physics end subroutine GFS_rrtmgp_setup_init ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_setup_run + ! SUBROUTINE GFS_rrtmgp_setup_timestep_init ! ######################################################################################### -!> \section arg_table_GFS_rrtmgp_setup_run -!! \htmlinclude GFS_rrtmgp_setup_run.html +!> \section arg_table_GFS_rrtmgp_setup_timestep_init +!! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_run (idate, jdate, deltsw, deltim, lsswr, me, & - slag, sdec, cdec, solcon, errmsg, errflg) + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, & + slag, sdec, cdec, solcon, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -188,7 +188,7 @@ subroutine GFS_rrtmgp_setup_run (idate, jdate, deltsw, deltim, lsswr, me, & ! Check initialization state if (.not.is_initialized) then - write(errmsg, fmt='((a))') 'GFS_rrtmgp_setup_run called before GFS_rrtmgp_setup_init' + write(errmsg, fmt='((a))') 'GFS_rrtmgp_setup_timestep_init called before GFS_rrtmgp_setup_init' errflg = 1 return end if @@ -251,7 +251,7 @@ subroutine GFS_rrtmgp_setup_run (idate, jdate, deltsw, deltim, lsswr, me, & if ( loz1st ) loz1st = .false. return - end subroutine GFS_rrtmgp_setup_run + end subroutine GFS_rrtmgp_setup_timestep_init ! ######################################################################################### ! SUBROUTINE GFS_rrtmgp_setup_finalize @@ -273,4 +273,5 @@ subroutine GFS_rrtmgp_setup_finalize (errmsg, errflg) is_initialized = .false. end subroutine GFS_rrtmgp_setup_finalize + end module GFS_rrtmgp_setup diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index fb31f5c7a..9a1d302ac 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -260,7 +260,7 @@ ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_setup_run + name = GFS_rrtmgp_setup_timestep_init type = scheme [idate] standard_name = date_and_time_at_model_initialization From c90a4d1c0322f4b4a6c37a382695a272d42eb4d6 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 31 Dec 2020 09:42:06 -0700 Subject: [PATCH 42/67] Remove additional/unnecessary SIMD instruction sets from CMakeLists.txt --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 2f8b7e9d6..7efe7bb5f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -180,7 +180,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2,CORE-AVX512" "-axSSE4.2,AVX,CORE-AVX-I" + string(REPLACE "-axSSE4.2,CORE-AVX2" "-axSSE4.2,CORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f From ddace04d7d2137a866a28b18ed3755232cbcfd19 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 5 Jan 2021 09:53:32 -0700 Subject: [PATCH 43/67] switch modulo calls for time intervals to 0 from 1 --- physics/GFS_phys_time_vary.scm.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index 5fcc9ed84..be62e5052 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -353,18 +353,18 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, !--- determine if diagnostics buckets need to be cleared sec_zero = nint(Model%fhzero*con_hr) if (sec_zero >= nint(max(Model%fhswr,Model%fhlwr))) then - if (mod(Model%kdt,Model%nszero) == 1) then + if (mod(Model%kdt,Model%nszero) == 0) then call Diag%rad_zero (Model) call Diag%phys_zero (Model) !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif else - if (mod(Model%kdt,Model%nszero) == 1) then + if (mod(Model%kdt,Model%nszero) == 0) then call Diag%phys_zero (Model) !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif kdt_rad = nint(min(Model%fhswr,Model%fhlwr)/Model%dtp) - if (mod(Model%kdt, kdt_rad) == 1) then + if (mod(Model%kdt, kdt_rad) == 0) then call Diag%rad_zero (Model) !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif From 2d8c061a3f6aead4e8e8184095fad5a049009429 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 6 Jan 2021 09:40:36 -0700 Subject: [PATCH 44/67] Update CMakeLists.txt to look for the cmake include snippets in the right place --- CMakeLists.txt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 2f8b7e9d6..88d6240f0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -72,7 +72,7 @@ set(TYPEDEFS $ENV{CCPP_TYPEDEFS}) if(TYPEDEFS) message(STATUS "Got CCPP TYPEDEFS from environment variable: ${TYPEDEFS}") else(TYPEDEFS) - include(./CCPP_TYPEDEFS.cmake) + include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_TYPEDEFS.cmake) message(STATUS "Got CCPP TYPEDEFS from cmakefile include file: ${TYPEDEFS}") endif(TYPEDEFS) @@ -88,7 +88,7 @@ set(SCHEMES $ENV{CCPP_SCHEMES}) if(SCHEMES) message(STATUS "Got CCPP SCHEMES from environment variable: ${SCHEMES}") else(SCHEMES) - include(./CCPP_SCHEMES.cmake) + include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_SCHEMES.cmake) message(STATUS "Got CCPP SCHEMES from cmakefile include file: ${SCHEMES}") endif(SCHEMES) @@ -97,7 +97,7 @@ set(CAPS $ENV{CCPP_CAPS}) if(CAPS) message(STATUS "Got CCPP CAPS from environment variable: ${CAPS}") else(CAPS) - include(./CCPP_CAPS.cmake) + include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_CAPS.cmake) message(STATUS "Got CCPP CAPS from cmakefile include file: ${CAPS}") endif(CAPS) From ca1afdb3ecebea579cfe13848130756ef6b39411 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 6 Jan 2021 09:40:54 -0700 Subject: [PATCH 45/67] Add #ifdef CCPP to three NoahMP routines --- physics/module_sf_noahmp_glacier.f90 | 1 + physics/module_sf_noahmplsm.f90 | 3 ++- physics/sfc_noahmp_drv.f | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index f3e0531f5..0b3749b5a 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1,3 +1,4 @@ +#define CCPP !> \file module_sf_noahmp_glacier.f90 !! This file contains the NoahMP Glacier scheme. diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 02ea70a6e..567f4a0cf 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1,9 +1,10 @@ +#define CCPP !> \file module_sf_noahmplsm.f90 !! This file contains the NoahMP land surface model. !>\ingroup NoahMP_LSM module module_sf_noahmplsm -#ifndef CCPP +#ifndef CCPP use module_wrf_utl #endif diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 963810734..f60a4233f 100644 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -1,3 +1,4 @@ +#define CCPP !> \file sfc_noahmp_drv.f !! This file contains the NoahMP land surface scheme driver. From 2950112f1d1334e942011e8adee9d217953c6316 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 8 Jan 2021 08:55:10 -0700 Subject: [PATCH 46/67] Add missing dependency of module_radiation_clouds on module_mp_thompson to metadata --- physics/GFS_rrtmg_setup.meta | 3 ++- physics/GFS_rrtmgp_pre.meta | 2 +- physics/GFS_rrtmgp_setup.meta | 3 ++- physics/module_SGSCloud_RadPre.meta | 2 +- 4 files changed, 6 insertions(+), 4 deletions(-) diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index b8d94db6c..f772fd2f9 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f + dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f, + dependencies = module_mp_thompson.F90,radiation_gases.f,radiation_surface.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f, ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index d07f9c137..fd7067ca6 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,rrtmgp_aux.F90,rrtmg_lw_cloud_optics.F90 + dependencies = radiation_astronomy.f,radiation_clouds.f,module_mp_thompson.F90,radiation_gases.f,radiation_surface.f,rrtmgp_aux.F90,rrtmg_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index fb31f5c7a..9f23636c1 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rrtmgp_setup type = scheme - dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,physparam.f,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f + dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,physparam.f,radiation_aerosols.f,radiation_astronomy.f + dependencies = module_mp_thompson.F90,radiation_clouds.f,radiation_gases.f,radiation_surface.f ######################################################################## [ccpp-arg-table] diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/module_SGSCloud_RadPre.meta index c01cd94af..e9a18df8b 100644 --- a/physics/module_SGSCloud_RadPre.meta +++ b/physics/module_SGSCloud_RadPre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sgscloud_radpre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_clouds.f + dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_clouds.f,module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] From 918eca147d6646386a701fcbaef6d40f2b6a8a48 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 8 Jan 2021 16:47:49 +0000 Subject: [PATCH 47/67] Added lower limit to temperature used by RRTMGP. --- physics/GFS_rrtmgp_pre.F90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 73828999f..b5d1dbe1a 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -252,6 +252,15 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, ! Temperature at layer-center t_lay(1:NCOL,:) = tgrs(1:NCOL,:) + ! Bound temperature at layer centers. + do iCol=1,NCOL + do iLay=1,nLev + if (t_lay(iCol,iLay) .le. lw_gas_props%get_temp_min()) then + t_lay = lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) + endif + enddo + enddo + ! Temperature at layer-interfaces if (top_at_1) then tem2da(1:nCol,2:iSFC) = log(p_lay(1:nCol,2:iSFC)) From 6d1994c8f37a4c410031e832875ba94a77c099a2 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Sat, 9 Jan 2021 19:47:02 -0500 Subject: [PATCH 48/67] update Jan 9 2021 from NCAR/ccpp-physics --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 33c8a984c..566bee9cd 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 33c8a984c17cf41be5d4c2928242e1b4239bfc40 +Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d From 7ddfb71983707d81252b3644cf0bafa340642942 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Sat, 9 Jan 2021 21:36:01 -0500 Subject: [PATCH 49/67] cires_ugwpv1*90 new ; ugwpv1_gsldrag* new unified_ugwp.* modified --- physics/cires_ugwpv1_initialize.F90 | 805 +++++++++++++++++ physics/cires_ugwpv1_module.F90 | 557 ++++++++++++ physics/cires_ugwpv1_oro.F90 | 1279 +++++++++++++++++++++++++++ physics/cires_ugwpv1_solv2.F90 | 1045 ++++++++++++++++++++++ physics/cires_ugwpv1_sporo.F90 | 353 ++++++++ physics/cires_ugwpv1_triggers.F90 | 446 ++++++++++ physics/ugwpv1_gsldrag.F90 | 671 ++++++++++++++ physics/ugwpv1_gsldrag.meta | 1265 ++++++++++++++++++++++++++ physics/ugwpv1_gsldrag_post.F90 | 107 +++ physics/ugwpv1_gsldrag_post.meta | 321 +++++++ physics/unified_ugwp.F90 | 205 +---- 11 files changed, 6857 insertions(+), 197 deletions(-) create mode 100644 physics/cires_ugwpv1_initialize.F90 create mode 100644 physics/cires_ugwpv1_module.F90 create mode 100644 physics/cires_ugwpv1_oro.F90 create mode 100644 physics/cires_ugwpv1_solv2.F90 create mode 100644 physics/cires_ugwpv1_sporo.F90 create mode 100644 physics/cires_ugwpv1_triggers.F90 create mode 100644 physics/ugwpv1_gsldrag.F90 create mode 100644 physics/ugwpv1_gsldrag.meta create mode 100644 physics/ugwpv1_gsldrag_post.F90 create mode 100644 physics/ugwpv1_gsldrag_post.meta diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/cires_ugwpv1_initialize.F90 new file mode 100644 index 000000000..1050da194 --- /dev/null +++ b/physics/cires_ugwpv1_initialize.F90 @@ -0,0 +1,805 @@ +!=============================== +! cu-cires ugwp-scheme +! initialization of selected +! init gw-solvers (1,2,3,4) +! init gw-source specifications +! init gw-background dissipation +!============================== +! +! Part-0 specifications of common constants, limiters and "criiical" values +! +! + + module ugwp_common +! + use machine, only : kind_phys +! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & +! rv => con_rv, cpd => con_cp, fv => con_fvirt,& +! arad => con_rerth + implicit none + + real(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. + real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 + real(kind=kind_phys), parameter :: grav2 = grav + grav + real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 + real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd + real(kind=kind_phys), parameter :: gor = grav/rd + real(kind=kind_phys), parameter :: gr2 = grav*gor + real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp + real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g + real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp + + real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi + real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 + + real(kind=kind_phys), parameter :: arad = 6370.e3 +! + real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) + real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) + + real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 + real(kind=kind_phys), parameter :: omega1 = pi2/86400. + real(kind=kind_phys), parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 + real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp + real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin + real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax + real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax + + end module ugwp_common +! +! +!=================================================== +! +!Part-1 init => wave dissipation + RFriction +! +!=================================================== + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + me, master) +! +! ccpp-damn con_pi !!! +! +!non-ccpp subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +!non-ccpp use ugwp_common, only : pih + + use machine , only : kind_phys + + + implicit none + integer , intent(in) :: me, master + integer , intent(in) :: levs + real(kind=kind_phys), intent(in) :: con_pi + real(kind=kind_phys), intent(in) :: zkm(levs), pmb(levs) ! in km-Pa + real(kind=kind_phys), intent(out), dimension(levs+1) :: kvg, ktg, krad, kion +! +!locals + data +! + integer :: k + real(kind=kind_phys), parameter :: vusurf = 2.e-5 + real(kind=kind_phys), parameter :: musurf = vusurf/1.95 + real(kind=kind_phys), parameter :: hpmol = 7.0 +! + real(kind=kind_phys), parameter :: kzmin = 0.1 + real(kind=kind_phys), parameter :: kturbo = 100. + real(kind=kind_phys), parameter :: zturbo = 130. + real(kind=kind_phys), parameter :: zturw = 30. + real(kind=kind_phys), parameter :: inv_pra = 3. !kt/kv =inv_pr +! + real(kind=kind_phys), parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days + real(kind=kind_phys) :: pa_alp = 750. ! super-RF parameters from FV3-dycore GFSv17/16 sett + real(kind=kind_phys) :: tau_alp = 10. ! days (750 Pa /10days) +! + real(kind=kind_phys), parameter :: kdrag = 1./86400./30. !parametrization for WAM ion drag as e-density function + real(kind=kind_phys), parameter :: zdrag = 100. + real(kind=kind_phys), parameter :: zgrow = 50. +! + real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag + real(kind=kind_phys) :: rf_fv3, rtau_fv3, ptop, pih_dlog +! + real(kind=kind_phys) :: ae1 ,ae2 +! +! ccpp con_pi +! + real(kind=kind_phys) :: pih + pih = 0.5*con_pi + + ptop = pmb(levs) + rtau_fv3 = 1./86400./tau_alp + pih_dlog = pih/log(pa_alp/ptop) + + do k=1, levs + ae1 = zkm(k)/hpmol + vumol = vusurf*exp(ae1) + mumol = musurf*exp(ae1) + ae2 = -((zkm(k)-zturbo) /zturw)**2 + keddy = kturbo*exp(ae2) + + kvg(k) = vumol + keddy + ktg(k) = mumol + keddy*inv_pra + + krad(k) = alpha +! + ion_drag = kdrag +! + kion(k) = ion_drag! +! add Rayleigh_Super of FV3 for pmb < pa_alp +! + if (pmb(k) .le. pa_alp) then + rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 + krad(k) = krad(k) + rf_fv3 + kion(k) = kion(k) + rf_fv3 + + endif + +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) + enddo + + k= levs+1 + kion(k) = kion(k-1) + krad(k) = krad(k-1) + kvg(k) = kvg(k-1) + ktg(k) = ktg(k-1) + + if (me == master) then + write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ... init_global_gwdis' + do k=1, levs, 1 + write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) + enddo + endif +! + 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) + + end subroutine init_global_gwdis +! +! ======================================================================== +! Part 2 - sources +! wave sources +! ======================================================================== +! +! ugwp_oro_init +! +!========================================================================= + module ugwp_oro_init + use machine , only : kind_phys + use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common, only : mkzmin, mkz2min + implicit none +! +! constants and "crirtical" values to run oro-mtb_gw physics +! +! + real(kind=kind_phys), parameter :: hncrit=9000. ! max value in meters for elvmax + real(kind=kind_phys), parameter :: hminmt=50. ! min mtn height (*j*) + real(kind=kind_phys), parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor + real(kind=kind_phys), parameter :: hpmax=2500.0 + real(kind=kind_phys), parameter :: hpmin=25.0 +! +! + real(kind=kind_phys), parameter :: minwnd=1.0 ! min wind component (*j*) + real(kind=kind_phys), parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa + + + character(len=8) :: strver = 'gfs_2018' + character(len=8) :: strbase = 'gfs_2018' + real(kind=kind_phys), parameter :: rimin=-10., ric=0.25 + + real(kind=kind_phys), parameter :: frmax=10., frc =1.0, frmin =0.01 + real(kind=kind_phys), parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real(kind=kind_phys), parameter :: gmax=1.0, veleps=1.0, factop=0.5! + real(kind=kind_phys), parameter :: efmin=0.5, efmax=10.0 + + real(kind=kind_phys), parameter :: rlolev=50000.0 + integer,parameter :: mdir = 8 + real(kind=kind_phys), parameter :: fdir=.5*mdir/pi + + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir + + real(kind=kind_phys), parameter :: odmin = 0.1, odmax = 10.0 + real(kind=kind_phys), parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm + real(kind=kind_phys), parameter :: fcrit_gfs = 0.7, fcrit_v1 = 0.7 + real(kind=kind_phys), parameter :: fcrit_mtb = 0.7 + + real(kind=kind_phys), parameter :: zbr_pi = (1.0/2.0)*pi + real(kind=kind_phys), parameter :: zbr_ifs = 0.5*pi + +! + + real(kind=kind_phys), parameter :: kxoro=6.28e-3/200. ! + real(kind=kind_phys), parameter :: coro = 0.0 + integer,parameter :: nridge=2 + real(kind=kind_phys), parameter :: sigma_std=1./100., gamm_std=1.0 + + real(kind=kind_phys) :: cdmb ! scale factors for mtb + real(kind=kind_phys) :: cleff ! scale factors for orogw + + integer :: nworo ! number of waves + integer :: nazoro ! number of azimuths + integer :: nstoro ! flag for stochastic launch above SG-peak + + +!------------------------------------------------------------------------------ +! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS +! SA-option can be controlled by Integral limits of fluxes +! in B2004: klow = 0.003 1/m ~ 2km and kinf ~ 6.28/10/(Z1)~< 1 km => meters +! these limits can change strength of TOFD... choice of k0tr ~1/10 km (10km ~dx of C768) +! kmax = kdis_pbl +!------------------------------------------------------------------------------ + real(kind=kind_phys), parameter :: kmax = 6.28/(10.*25.) ! max k-tofd + real(kind=kind_phys), parameter :: k1tr = 6.28/(2100) ! max k-transition from -1.9/slope to -2.8/slope + real(kind=kind_phys), parameter :: kflt = 6.28/(18.e3) ! + real(kind=kind_phys), parameter :: k0tr = 6.28/(10.e3) ! min k-tofd + real(kind=kind_phys), parameter :: nk1tr = 2.8 + real(kind=kind_phys), parameter :: nk0tr = 1.9 + real(kind=kind_phys), parameter :: a1_tofd = kflt ** nk1tr *1.e3 + real(kind=kind_phys), parameter :: a2_tofd = k1tr ** (nk0tr-nk1tr) + real(kind=kind_phys), parameter :: fix_tofd = 2.* 0.005 * 12 *0.6 !value= 0.072 +! +! B2004 scheme is based on the empirical vertical profile of the tofd divergence: +! Ax_tofd(Z)=exp(-[Z/ze_tofd]^3/2) / Z^1.2..... +! TOFD-flux/TMS-flux must dissipate due to PBL-diffusion with spectral damping +! Here we can enhance TOFD-impact by selecting k0tr and kmax limits +! as functions of resolution and PBL-dissipation +! + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real(kind=kind_phys), parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real(kind=kind_phys), parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters, 1.5 km + real(kind=kind_phys), parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real(kind=kind_phys), parameter :: ztop_tofd = 3.*ze_tofd ! no TOFD > this height 4.5 km +!------------------------------------------------------------------------------ +! + + contains +! + subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + lonr, kxw ) +! +! + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: cdmbX + real(kind=kind_phys) :: kxw + real(kind=kind_phys) :: effac ! it is analog of cdmbgwd(2) for GWs, off for now +!-----------------------------! GFS-setup for cdmb & cleff +! cdmb = 4.0 * (192.0/IMX) +! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) +! + real(kind=kind_phys), parameter :: lonr_refmb = 4.0 * 192.0 + real(kind=kind_phys), parameter :: lonr_refgw = 192.0 + real(kind=kind_phys), parameter :: cleff_ref = 0.5e-5 ! 1256 km = 10 * 125 km ??? + +! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch + + nworo = nwaves + nazoro = nazdir + nstoro = nstoch + + cdmbX = lonr_refmb/float(lonr) + + cdmb = cdmbX + cleff = cleff_ref * sqrt(lonr_refgw/float(lonr)) !* effac +! + end subroutine init_oro_gws +! + + end module ugwp_oro_init +! ========================================================================= +! +! ugwp_conv_init +! +!========================================================================= + module ugwp_conv_init + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + implicit none + real(kind=kind_phys) :: eff_con ! scale factors for conv GWs + integer :: nwcon ! number of waves + integer :: nazcon ! number of azimuths + integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud + real(kind=kind_phys) :: con_dlength + real(kind=kind_phys) :: con_cldf + + real(kind=kind_phys), parameter :: cmin = 5 !2.5 + real(kind=kind_phys), parameter :: cmax = 95. !82.5 + real(kind=kind_phys), parameter :: cmid = 22.5 + real(kind=kind_phys), parameter :: cwid = cmid + real(kind=kind_phys), parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 + real(kind=kind_phys), parameter :: mstar = 6.28e-3/2. ! 2km + real(kind=kind_phys) :: dc + + real(kind=kind_phys), allocatable :: ch_conv(:), spf_conv(:) + real(kind=kind_phys), allocatable :: xaz_conv(:), yaz_conv(:) + contains +! + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & + con_pi, arad, lonr, kxw) +! +! non-ccpp with use ugwp_common +! +! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & +! lonr, kxw) +! +! use ugwp_common, only : pi2, arad + + + + implicit none + + + integer :: nwaves, nazdir, nstoch + integer :: lonr +! +! ccpp +! + real(kind=kind_phys) :: con_pi, arad + + real(kind=kind_phys) :: kxw, effac + real(kind=kind_phys) :: work1 = 0.5 + real(kind=kind_phys) :: chk, tn4, snorm + integer :: k + + nwcon = nwaves + nazcon = nazdir + nstcon = nstoch + eff_con = effac + + con_dlength = 2.0*con_pi*arad/float(lonr) +! +! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" +! + if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) + if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) + if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) + if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) +! +! we may use different spectral "shapes" +! for example FVS-93 "Desabeius" +! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail +! + do k = 1,nwaves + chk = cmin + (k-1)*dc + tn4 = (mstar*chk)**4 + ch_conv(k) = chk + spf_conv(k) = bns4*chk/(bns4+tn4) + enddo + + snorm = sum(spf_conv) + spf_conv = spf_conv/snorm*1.5 + + call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) + end subroutine init_conv_gws + + + end module ugwp_conv_init +!========================================================================= +! +! ugwp_fjet_init +! +!========================================================================= + + module ugwp_fjet_init + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + + implicit none + real(kind=kind_phys) :: eff_fj ! scale factors for conv GWs + integer :: nwfj ! number of waves + integer :: nazfj ! number of azimuths + integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud +! + real(kind=kind_phys), parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet + + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_fjet(:) , spf_fjet(:) + real(kind=kind_phys), allocatable :: xaz_fjet(:), yaz_fjet(:) + contains + + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) +! non-ccpp +! +! subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) +! use ugwp_common, only : pi2, arad + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: con_pi + real(kind=kind_phys) :: kxw, effac , chk + + integer :: k + + nwfj = nwaves + nazfj = nazdir + nstfj = nstoch + eff_fj = effac + + if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) + if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) + if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) + if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) + + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_fjet(k) = chk + spf_fjet(k) = 1.0 + enddo + call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) + + end subroutine init_fjet_gws + + end module ugwp_fjet_init +! +!========================================================================= +! +! + module ugwp_okw_init +!========================================================================= + use machine , only : kind_phys + use cires_ugwpv1_triggers, only :init_nazdir + implicit none + + real(kind=kind_phys) :: eff_okw ! scale factors for conv GWs + integer :: nwokw ! number of waves + integer :: nazokw ! number of azimuths + integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud +! + real(kind=kind_phys), parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet + + real(kind=kind_phys), parameter :: cmin = 2.5 + real(kind=kind_phys), parameter :: cmax = 67.5 + real(kind=kind_phys) :: dc + real(kind=kind_phys), allocatable :: ch_okwp(:), spf_okwp(:) + real(kind=kind_phys), allocatable :: xaz_okwp(:), yaz_okwp(:) + + contains +! + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & + con_pi, lonr, kxw) + +! subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) +! use ugwp_common, only : pi2, arad + + implicit none + + integer :: nwaves, nazdir, nstoch + integer :: lonr + real(kind=kind_phys) :: con_pi + real(kind=kind_phys) :: kxw, effac , chk + + integer :: k + + nwokw = nwaves + nazokw = nazdir + nstokw = nstoch + eff_okw = effac + + if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) + if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) + if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) + if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) + dc = (cmax-cmin)/float(nwaves-1) + do k = 1,nwaves + chk = cmin + (k-1)*dc + ch_okwp(k) = chk + spf_okwp(k) = 1. + enddo + + call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) +! non-ccpp +! call init_nazdir(nazdir, xaz_okwp, yaz_okwp) +! + end subroutine init_okw_gws + + end module ugwp_okw_init + +!=============================== end of GW sources +! +! init specific gw-solvers (1,2,3,4) +! +!=============================== +! Part -3 init wave solvers +!=============================== + + module ugwp_lsatdis_init + use machine , only : kind_phys + implicit none + + integer :: nwav, nazd + integer :: nst + real(kind=kind_phys) :: eff + integer, parameter :: incdim = 4, iazdim = 4 +! + contains + + subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + + implicit none +! + integer :: me, master + integer :: nwaves, nazdir + integer :: nstoch + real(kind=kind_phys) :: effac + logical :: do_physb + real(kind=kind_phys) :: kxw +! +!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces +! are not actibve +! + integer :: inc, jk, jl, iazi, i, j, k + + if( nwaves == 0 .or. nstoch == 1 ) then +! redefine from the default + nwav = incdim + nazd = iazdim + nst = 0 + eff = 1.0 + else +! from input_nml multi-wave spectra + nwav = nwaves + nazd = nazdir + nst = nstoch + eff = effac + endif +! + end subroutine initsolv_lsatdis +! + end module ugwp_lsatdis_init +! +! + module ugwp_wmsdis_init + use machine , only : kind_phys + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 + use ugwp_common, only : bnv2max, bnv2min, minvel + use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin + + implicit none + + real(kind=kind_phys), parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 + real(kind=kind_phys), parameter :: dked_min =0.01, dked_max=250.0 + + real(kind=kind_phys), parameter :: gptwo=2.0 + + real(kind=kind_phys) , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real(kind=kind_phys) , parameter :: bnfix4 = bnfix2 * bnfix2 + real(kind=kind_phys) , parameter :: bnfix3 = bnfix2 * bnfix +! +! make parameter list that will be passed to SOLVER +! + integer , parameter :: iazidim=4 ! number of azimuths + integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum + real(kind=kind_phys) , parameter :: ucrit=cdmin + + real(kind=kind_phys) , parameter :: zcimin = 2.5 + real(kind=kind_phys) , parameter :: zcimax = 125.0 + real(kind=kind_phys) , parameter :: zgam = 0.25 +! +! Verical spectra +! + real(kind=kind_phys) , parameter :: pind_wd = 5./3. + real(kind=kind_phys) , parameter :: sind_kz = 1. + real(kind=kind_phys) , parameter :: tind_kz = 3. + real(kind=kind_phys) , parameter :: stind_kz = sind_kz + tind_kz +! +! copies from kmob_ugwp namelist +! + real(kind=kind_phys) :: nslope ! the GW sprctral slope at small-m + real(kind=kind_phys) :: lzstar + real(kind=kind_phys) :: lzmin + real(kind=kind_phys) :: lzmax + real(kind=kind_phys) :: lhmet + real(kind=kind_phys) :: tamp_mpa !amplitude for GEOS-5/MERRA-2 + real(kind=kind_phys) :: tau_min ! min of GW MF 0.25 mPa + integer :: ilaunch + real(kind=kind_phys) :: gw_eff + + real(kind=kind_phys) :: v_kxw, rv_kxw, v_kxw2 + + + +!=========================================================================== + integer :: nwav, nazd, nst + real(kind=kind_phys) :: eff + + real(kind=kind_phys) :: zaz_fct, zms + real(kind=kind_phys), allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) + real(kind=kind_phys), allocatable :: zcosang(:), zsinang(:) + real(kind=kind_phys), allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) + +! +! GW-eddy constants for wave-mode dissipation by background and stability of +! "final" flow after application of GW-effects +! + real(kind=kind_phys), parameter :: iPr_pt = 0.5 + real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. + real(kind=kind_phys), parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable + real(kind=kind_phys), parameter :: ric =0.25 + real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 + real(kind=kind_phys), parameter :: prmax = 4.0 +! + contains +!============================================================================ + subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw, version) + +! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & +! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw,version) +! + implicit none +! +!input-control for solvers: +! nwaves, nazdir, nstoch, effac, do_physb, kxw +! +! + integer, intent(in) :: me, master, nwaves, nazdir, nstoch + integer, intent(in) :: version + + real(kind=kind_phys), intent(in) :: effac, kxw + logical, intent(in) :: do_physb + +! +!locals +! + real(kind=kind_phys) :: dlzmet + real(kind=kind_phys) :: cstar,rcstar, nslope3, fnorm, zcin + + integer :: inc, jk, jl, iazi +! + real(kind=kind_phys) :: zang, zang1, znorm + real(kind=kind_phys) :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp + real(kind=kind_phys) :: fpc, fpc_dc + real(kind=kind_phys) :: ae1,ae2 + if( nwaves == 0) then +! +! redefine from the deafault +! + nwav = incdim + nazd = iazidim + nst = 0 + eff = 1.0 + gw_eff = eff + else +! +! from input.nml +! + nwav = nwaves + nazd = nazdir + nst = nstoch + gw_eff = effac + endif + + + v_kxw = kxw ; v_kxw2 = v_kxw*v_kxw + rv_kxw = 1./v_kxw + + allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) + allocate ( zcosang(nazd), zsinang(nazd) ) + allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) + + if (me == master) then + print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' +! + print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch + print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. + print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 + endif + + zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. + +! +! set up azimuth directions and some trig factors +! +! + zang = pi2 / float(nazd) + +! get normalization factor to ensure that the same amount of momentum +! flux is directed (n,s,e,w) no mater how many azimuths are selected. +! + znorm = 0.0 + do iazi=1, nazd + zang1 = (iazi-1)*zang + zcosang(iazi) = cos(zang1) + zsinang(iazi) = sin(zang1) + znorm = znorm + abs(zcosang(iazi)) + enddo +! zaz_fct = 1.0 + zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums + +! define coordinate transform for "Ch" ....x = 1/c stretching transform +! ----------------------------------------------- +! +! x=1/Cphase transform +! Scinocca 2003. x = 1/c stretching transform +! + zxmax = 1.0 / zcimin + zxmin = 1.0 / zcimax + zxran = zxmax - zxmin + zdx = zxran / real(nwav-1) ! dkz +! + ae1=zxran/zgam + zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. + zx2 = zxmin - zx1 + +! +! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform +! it represents additional "empirical" redistribution of "spectral" mode in C-space +! + zms = pi2 / lzstar + + do inc=1, nwav + ztx = real(inc-1)*zdx+zxmin + ae1 = (ztx-zxmin)/zgam + zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 + zci(inc) = 1.0 /zx ! + zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + enddo +! +! +! alternatuve lzmax-lzmin without x=1/c transform +! +! + if (version == 1) then + + dlzmet = (lzmax-lzmin)/ real(nwav-1) + do inc=1, nwav + lzmet(inc) = lzmin + (inc-1)*dlzmet + mkzmet(inc) = pi2/lzmet(inc) + zci(inc) =lzmet(inc)/(pi2/bnfix) + zci4(inc) = (zms*zci(inc))**4 + zci2(inc) = (zms*zci(inc))**2 + zci3(inc) = (zms*zci(inc))**3 + + enddo + + zdx = (zci(nwav)-zci(1))/ real(nwav-1) + do inc=1, nwav + zdci(inc) = zdx + enddo + + cstar = bnfix/zms + rcstar = 1./cstar + + if (me == master) then + print * + print *, 'ugwp_v0: zcimin=' , zcimin + print *, 'ugwp_v0: zcimax=' , zcimax + print *, 'ugwp_v0: zgam= ', zgam + print * + +! print *, ' ugwp_v1 nslope=', nslope + print * + print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) + print *, 'ugwp_v1: zcimax/zci=' , minval(zci) + print *, 'ugwp_v1: cd_crit=', ucrit + print *, 'ugwp_v1: launch_level', ilaunch + print *, ' ugwp_v1 lzstar=', lzstar + print *, ' ugwp_v1 nslope=', nslope + + print * + nslope3=nslope+3.0 + do inc=1, nwav + zcin =zci(inc)*rcstar + fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) + fpc_dc = fpc * zdci(inc) + write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) + enddo + endif + + ENDIF ! if (version == 1) then + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) + + end subroutine initsolv_wmsdis +! +! + end module ugwp_wmsdis_init diff --git a/physics/cires_ugwpv1_module.F90 b/physics/cires_ugwpv1_module.F90 new file mode 100644 index 000000000..eb740c7eb --- /dev/null +++ b/physics/cires_ugwpv1_module.F90 @@ -0,0 +1,557 @@ + +module cires_ugwpv1_module + +! +! driver is called after pbl & before chem-parameterizations +! it uses ugwp_common (like phys_cons) and some module-param od solvers/sources init-modules +!.................................................................................... +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +!................................................................................... +! +! + use machine, only : kind_phys + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + + implicit none + logical :: module_is_initialized + + character(len=8) :: strsolver='pss-1986' + logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources + logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver + integer, parameter :: idebug_gwrms=0 ! control for diag computaions pw wind-temp GW-rms and MF fluxs + logical, parameter :: do_adjoro = .false. + real(kind=kind_phys), parameter :: max_kdis = 450. ! 400 m2/s + real(kind=kind_phys), parameter :: max_axyz = 450.e-5 ! 400 m/s/day + real(kind=kind_phys), parameter :: max_eps = max_kdis*4.e-4 ! max_kdis*BN2 + real(kind=kind_phys), parameter :: maxdudt = max_axyz + real(kind=kind_phys), parameter :: maxdtdt = max_eps*1.e-3 ! max_kdis*BN2/cp + real(kind=kind_phys), parameter :: dked_min = 0.01 + real(kind=kind_phys), parameter :: dked_max = max_kdis +! +! +! Pr = Kv/Kt < 1 for upper layers; Pr_mol = 1./1.95 check it +! + real(kind=kind_phys), parameter :: Pr_kvkt = 1./1. ! kv/kt = 1./3. + real(kind=kind_phys), parameter :: Pr_kdis = Pr_kvkt/(1.+Pr_kvkt) + + real(kind=kind_phys), parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw + real(kind=kind_phys), parameter :: iPr_turb =1./3., iPr_mol =1.95 + + + real(kind=kind_phys), parameter :: hps = hpscale + real(kind=kind_phys), parameter :: hpskm = hps/1000. +! + real(kind=kind_phys), parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 + real(kind=kind_phys), parameter :: khp = 0.287*rhp1 ! R/Cp/Hp + + real(kind=kind_phys), parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model + real(kind=kind_phys), parameter :: linsat = 1.00 + real(kind=kind_phys), parameter :: linsat2 = linsat*linsat + + real(kind=kind_phys), parameter :: ricrit = 0.25 + real(kind=kind_phys), parameter :: frcrit = 0.50 + + + integer :: knob_ugwp_version = 1 + integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) + integer, dimension(4) :: knob_ugwp_source=(/1,0,1,0/) ! [1,0,1,1] - (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_wvspec=(/1,32,32,32/) ! number of waves for- (oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_azdir=(/2,4,4,4/) ! number of wave azimuths for-(oro, fronts, conv, imbf-owp] + integer, dimension(4) :: knob_ugwp_stoch=(/0,0,0,0/) ! 0 - deterministic ; 1 - stochastic + real(kind=kind_phys), dimension(4) :: knob_ugwp_effac=(/1.,1.,1.,1./) ! efficiency factors for- (oro, fronts, conv, imbf-owp] + + integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag + integer :: knob_ugwp_doheat=1 ! 1 -gwheat + integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing + integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw + integer :: knob_ugwp_nslope = 1 ! spectral"growth" S-slope of GW-energy spectra mkz^S + + real(kind=kind_phys) :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs + real(kind=kind_phys) :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km + real(kind=kind_phys) :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra + real(kind=kind_phys) :: knob_ugwp_taumin = 0.25e-3 + real(kind=kind_phys) :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) + real(kind=kind_phys) :: knob_ugwp_lhmet = 200.e3 ! 200 km + logical :: knob_ugwp_tlimb = .true. + character(len=8) :: knob_ugwp_orosolv='pss-1986' + + real(kind=kind_phys) :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes +! +! tune-ups for qbo +! +! real(kind=kind_phys) :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs +! real(kind=kind_phys) :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians +! real(kind=kind_phys) :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing +! real(kind=kind_phys) :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO +! real(kind=kind_phys) :: knob_ugwp_qbotau = 10. ! relaxation time scale in days +! real(kind=kind_phys) :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing +! real(kind=kind_phys) :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing +! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! +! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' +! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' +! integer, parameter :: ny_tab=73, nt_tab=14 +! real(kind=kind_phys), parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. +! integer :: nqbo_d1y, nqbo_d2z, nqbo_d3t + + integer :: ugwp_azdir + integer :: ugwp_stoch + + integer :: ugwp_src + integer :: ugwp_nws + real(kind=kind_phys) :: ugwp_effac + +! + integer :: launch_level = 55 +! + namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & + knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & + knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & + knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & + knob_ugwp_tlimb, knob_ugwp_orosolv + +! +! allocatable arrays, initilized during "cires_ugwp_init" & +! released during "cires_ugwp_finalize" +! + real(kind=kind_phys), allocatable :: kvg(:), ktg(:), krad(:), kion(:) + real(kind=kind_phys), allocatable :: zkm(:), pmb(:) + real(kind=kind_phys), allocatable :: rfdis(:), rfdist(:) + integer :: levs_rf + real(kind=kind_phys) :: pa_rf, tau_rf +!........................................................................................... +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +!........................................................................................... + +! integer :: ntau_d1y, ntau_d2t +! real(kind=kind_phys), allocatable :: ugwp_taulat(:) +! real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) +! logical :: flag_alloctau = .false. +! character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' +! +! simple modulation of tau_ngw by the total rain/precip strength +! + real(kind=kind_phys), parameter :: rain_max=8.e-5, rain_lat=41.0, rain_lim=1.e-5 + real(kind=kind_phys), parameter :: w_merra = 1.0, w_nomerra = 1.-w_merra, w_rain =1. + real(kind=kind_phys), parameter :: mtau_rain = 1.e-3, ft_min =0.5, ft_max=2 + real(kind=kind_phys), parameter :: tau_ngw_max = 20.e-3 ! 20 mPa + real(kind=kind_phys), parameter :: tau_ngw_min = .20e-3 ! .2 mPa +! +! Bushell et al. (2015) tau = tau_rainum (~3.8 km) x sqrt(Precip/base_rainum) +! + real(kind=kind_phys), parameter :: tau_rainum = 0.7488e-3 ! 0.74 mPa + real(kind=kind_phys), parameter :: base_rainum = 0.1e-5 ! ~0.1 mm/day + real(kind=kind_phys), parameter :: pbase_um =1./sqrt(base_rainum) * tau_rainum ! + integer, parameter :: metoum_rain = 0 +!================================================================= +! switches that can ba activated for NGW physics include/omit +! +! rotational, non-hydrostatic and eddy-dissipative +! F_coriol F_nonhyd F_kds +!=================================================== + real(kind=kind_phys), parameter :: F_coriol=1.0 ! Coriolis effects + real(kind=kind_phys), parameter :: F_nonhyd=1.0 ! Nonhydrostatic waves + real(kind=kind_phys), parameter :: F_kds =0.0 ! Eddy mixing due to GW-unstable below + + + contains +! +!----------------------------------------------------------------------- +! +! init of cires_ugwp (_init) called from CCPP cap file +! +! --------------------------------------------------------------------------------- +! non-ccpp .... +! +! subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, fn_nml2, & +! lonr, latr, levs, ak, bk, pref, dtp) +!----------------------------------------------------------------------------------- + + subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, & + errmsg, errflg) +! +! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 +! + use netcdf + use ugwp_oro_init, only : init_oro_gws + use ugwp_conv_init, only : init_conv_gws + use ugwp_fjet_init, only : init_fjet_gws + use ugwp_okw_init, only : init_okw_gws + use ugwp_lsatdis_init, only : initsolv_lsatdis + + use ugwp_wmsdis_init, only : initsolv_wmsdis + use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar + use ugwp_wmsdis_init, only : tau_min, tamp_mpa + + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + integer, intent (in) :: logunit + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + integer, intent (in) :: jdat_gfs(8) + real(kind=kind_phys), intent (in) :: ak(levs+1), bk(levs+1), pref + real(kind=kind_phys), intent (in) :: dtp +! +! consider to retire them +! + real(kind=kind_phys), intent (in) :: con_pi, con_rerth + + character(len=64), intent (in) :: fn_nml2 + character(len=64), parameter :: fn_nml='input.nml' + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! character, intent (in) :: input_nml_file +! + integer :: ios + logical :: exists + + integer :: ncid, iernc, vid, dimid, status + integer :: k + integer :: ddd_ugwp, curday_ugwp +! integer :: version + + +! + if (me == master) print *, trim (fn_nml), ' GW-namelist file ' + inquire (file =trim (fn_nml) , exist = exists) +! + if (.not. exists) then + if (me == master) & + write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' + + else + open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = cires_ugwp_nml) + close (nlunit) +! + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + strsolver= knob_ugwp_orosolv + + curday_ugwp = jdat_gfs(1)*10000 + jdat_gfs(2)*100 +jdat_gfs(3) + call calendar_ugwp(jdat_gfs(1), jdat_gfs(2), jdat_gfs(3), ddd_ugwp) + +! write version number and namelist to log file + if (me == master) then + write (logunit, *) " ================================================================== " + write (logunit, *) "CCPP cires_ugwp_namelist_extended_v1" + write (logunit, nml = cires_ugwp_nml) + write (logunit, *) " ================================================================== " + + write (6, *) " ================================================================== " + write (6, *) "CCPP cires_ugwp_namelist_extended_v1" + write (6, nml = cires_ugwp_nml) + write (6, *) " ================================================================== " + write (6, *) "calendar_ugwp ddd_ugwp=", ddd_ugwp + write (6, *) "calendar_ugwp curday_ugwp=", curday_ugwp + write (6, *) " ================================================================== " + write (6, *) ddd_ugwp, ' jdat_gfs ddd of year ' + endif +! +! effective kxw - resolution-aware +! +! + kxw = pi2/knob_ugwp_lhmet +! +! +! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff +! +! +! allocate(fcor(latr), fcor2(latr) ) +! + allocate( kvg(levs+1), ktg(levs+1) ) + allocate( krad(levs+1), kion(levs+1) ) + allocate( zkm(levs), pmb(levs) ) + +! +! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 +! + + do k=1, levs + pmb(k) = ak(k) + pref*bk(k) ! Pa -unit Pref = 1.e5, pmb = Pa + zkm(k) = -hpskm*alog(pmb(k)/pref) + enddo + +! +! find ilaunch +! + + do k=levs, 1, -1 + if (pmb(k) .gt. knob_ugwp_palaunch ) exit + enddo + + launch_level = max(k-1, 5) ! above 5-layers from the surface + if (me == master) then + print *, 'cires_ugwpv1 klev_ngw =', launch_level, nint(pmb(launch_level)) + endif +! +! Part-1 :init_global_gwdis again "damn"-con_pi +! call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & + me, master) +! +! Part-2 :init_SOURCES_gws +! + +! +! call init-solver for "stationary" multi-wave spectra and sub-grid oro +! + call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw ) +! +! call init-sources for "non-sationary" multi-wave spectra +! + do_physb_gwsrcs=.true. + + IF (do_physb_gwsrcs) THEN + + if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' + if (knob_ugwp_wvspec(4) > 0) then +! okw + call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & + knob_ugwp_stoch(4), knob_ugwp_effac(4), & + con_pi, lonr, kxw ) + if (me == master) print *, ' init_okw_gws ' + endif + + if (knob_ugwp_wvspec(3) > 0) then +! fronts + call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & + knob_ugwp_stoch(3), knob_ugwp_effac(3), & + con_pi, lonr, kxw ) + if (me == master) print *, ' init_fjet_gws ' + endif + + if (knob_ugwp_wvspec(2) > 0) then +! conv : con_pi, con_rerth, + call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), & + con_pi, con_rerth, lonr, kxw ) + if (me == master) & + print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + + endif + + ENDIF !IF (do_physb_gwsrcs) + +!====================== +! Part-3 :init_SOLVERS +! ===================== +! +! call init-solvers for "broad" non-stationary multi-wave spectra +! + if (knob_ugwp_solver==1) then +! + kxw = pi2/lhmet + call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) + endif + if (knob_ugwp_solver == 2) then +! +! re-assign from namelists +! + nslope = knob_ugwp_nslope ! the GW sprctral slope at small-m + lzstar = knob_ugwp_lzstar + lzmax = knob_ugwp_lzmax + lzmin = knob_ugwp_lzmin + lhmet = knob_ugwp_lhmet + tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 + tau_min =knob_ugwp_taumin ! min of GW MF 0.25 mPa + ilaunch = launch_level + + kxw = pi2/lhmet + + call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw, knob_ugwp_version) + + endif + + +!====================== + module_is_initialized = .true. + if (me == master) print *, ' CIRES_ugwpV1 is initialized ', module_is_initialized + + end subroutine cires_ugwpv1_init + + +!============================================= + + subroutine cires_ugwp_advance +!----------------------------------------------------------------------- +! FV3-dycore and CCPP-physics has limited options to +! add "horizontal" gradients of winds and temp-re to +! compute GW-triggers: reserved option if it will be funded ...... +! +! the day-to-day variable sources/spectra and diagnostics for stochastic "triggers" +! +! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields +! and use for stochastic GWP-sources "memory" +! +! this option is not active due to "weak" flexibility +! in communication between "ccpp/gfsphysics" and FV3-dycore +! extension of State%in is needed to pass horizontal gradients +! winds and temperature to compute "spontatneous" GW triggers +!----------------------------------------------------------------------- + implicit none +! +! update GW sources and dissipation +! a) physics-based GW triggers eliminated from cires_ugwpv1_triggers.F90 +! b) stochastic-based spectra and amplitudes is not considered +! c) use "memory" on GW-spectra from previous time-step is not considered +! d) update "background" dissipation of GWs as needed (option for FV3WAM) +! + end subroutine cires_ugwp_advance + +! +! ----------------------------------------------------------------------- +! finalize of cires_ugwp_dealloc +! ----------------------------------------------------------------------- + + + subroutine cires_ugwp_dealloc +! +! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" +! before "end" of the FV3GFS +! + implicit none +! +! deallocate arrays employed in: +! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! + if (allocated (kvg)) deallocate (kvg) + if (allocated (ktg)) deallocate (ktg) + if (allocated (krad)) deallocate (krad) + if (allocated (kion)) deallocate (kion) + if (allocated (zkm)) deallocate (zkm) + if (allocated (pmb)) deallocate (pmb) +! if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) +! if (allocated (tau_limb)) deallocate (tau_limb) +! if (allocated (days_limb)) deallocate(days_limb) + + + end subroutine cires_ugwp_dealloc + +! +! + subroutine calendar_ugwp(yr, mm, dd, ddd_ugwp) +! +! computes day of year to get tau_limb forcing written with 1-day precision +! + implicit none + integer, intent(in) :: yr, mm, dd + integer :: ddd_ugwp + + integer :: iw3jdn + integer :: jd1, jddd + jd1 = iw3jdn(yr,1,1) + jddd = iw3jdn(yr,mm,dd) + ddd_ugwp = jddd-jd1+1 + + end subroutine calendar_ugwp + + + subroutine ngwflux_update(me, master, im, levs, kdt, ddd, curdate, & + tau_ddd, xlatd, sinlat,coslat, rain, tau_ngw) + + use machine, only: kind_phys + implicit none +!input + + integer, intent(in) :: me, master !, jdat(8) + integer, intent(in) :: im, levs, kdt + integer, intent(in) :: ddd, curdate + +! integer, intent(in), dimension(im) :: j1_tau, j2_tau +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j2tau, ddy_j1tau + + real(kind=kind_phys), intent(in), dimension(im) :: xlatd, sinlat,coslat + real(kind=kind_phys), intent(in), dimension(im) :: rain, tau_ddd + + real(kind=kind_phys), intent(inout), dimension(im) :: tau_ngw +! +! locals +! + + integer :: i, j1, j2, k, it1, it2, iday + real(kind=kind_phys) :: tem, tx1, tx2, w1, w2, wlat, rw1, rw2 + real(kind=kind_phys) :: tau_rain, flat_rain, tau_3dt + +! + +! code below inside cires_tauamf_data.F90 +! it1 = 2 +! do iday=1, ntau_d2t +! if (float(ddd) .lt. days_limb(iday) ) then +! it2 = iday +! exit +! endif +! enddo +! it2 = min(it2,ntau_d2t) +! it1 = max(it2-1,1) +! if (it2 > ntau_d2t ) then +! print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t +! stop +! endif +! w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) +! w1 = 1.0-w2 +! do i=1, im +! j1 = j1_tau(i) +! j2 = j2_tau(i) +! tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) +! tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) +! tau_ddd(i) = tx1*w1 + w2*tx2 +! +! add modulattion by the total "rain"-strength Yudin et al.(2020-FV3GFS) and Bushell et al. (2015-UM/METO) +! + do i=1, im + tau_3dt = tau_ngw(i) * w_merra + w_nomerra *tau_ddd(i) + + if (w_rain > 0. .and. rain(i) > 0.) then + + wlat = abs(xlatd(i)) + + if (wlat <= rain_lat .and. rain(i) > rain_lim) then + flat_rain = wlat/rain_lat + rw1 = 0.75 * flat_rain ; rw2 = 1.-rw1 + + tau_rain = tau_3dt * rw1 + rw2 * mtau_rain*min(rain_max, rain(i))/rain_lim + tau_rain = tau_3dt*(1.-w_rain) + w_rain* tau_rain +! +! restict variations from the "tau_ngw" without precip-impact +! +! real, parameter :: ft_min =0.5*tau_g5 < tau_rain < ft_max =2. *tau_g5 +! + if (tau_rain < ft_min *tau_3dt) tau_rain = ft_min *tau_3dt + if (tau_rain > ft_max *tau_3dt) tau_rain = ft_max *tau_3dt + + tau_3dt = tau_rain + + endif + if (metoum_rain == 1) then + tau_rain = min( sqrt(rain(i))*pbase_um, tau_ngw_max) + tau_3dt = max(tau_ngw_min, tau_rain) + endif + endif + tau_ngw(i) = tau_3dt + enddo + + end subroutine ngwflux_update +! + end module cires_ugwpv1_module + diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 new file mode 100644 index 000000000..6913b4c0e --- /dev/null +++ b/physics/cires_ugwpv1_oro.F90 @@ -0,0 +1,1279 @@ +module cires_ugwpv1_oro + +contains + + subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & + grav, con_omega, rd, cpd, rv, pi, arad, fv, & + xlatd, sinlat, coslat, sparea, & + cdmbgwd, hprime, oc, oa4, clx4, theta, sigmad, & + gammad, elvmaxd, sgh30, kpbl, & + u1 ,v1, t1, q1, prsi,del,prsl,prslk, zmeti, zmet, & + pdvdt, pdudt, pdtdt, pkdis, dusfc, dvsfc,rdxzb , & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) + +! call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & +! con_g, con_omega, con_rd, con_cp, con_rv,con_pi, con_rerth, con_fvirt, & +! xlat_d, sinlat, coslat, area, & +! cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & +! sigma, gamma, elvmax, varss, kpbl, & +! ugrs, vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & +! Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & +! zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & +! dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & +! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & +! du_ofdcol, dv_ofdcol, errmsg,errflg ) + +!--------------------------------------------------------------------------- +! ugwp_v1: orogw_v1 following recent updates of Lott & Miller 1997 +! eventually will be replaced with more "advanced" LLWB +! and multi-wave solver that produce competitive FV3GFS-skills +! +! computation of kref for ogw + coorde diagnostics +! all constants/parameters inside cires_ugwp_initialize.f90 +! +! 10/2020 main updates +! (a) introduce extra diagnostics of x-y obl-ofd-ogw as in the GSL-drag +! for intercomparisons +! +! (b) quit with cdmbgwd(1:2) +! cdmbgwd(1) = 1 for all resolutions, number of hills control SA-effects +! cdmbgwd(2) = 1 ...............number of hills control SA-effects +! +! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) +! alternative lheff = min( dogw=hprime/sigma*gamma, dx) +! we still not use the "broad spectral solver" +! +! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW +! +! (e) for linsat-solver "eddy" damping Ked = Ked * Nhills, scale-aware +! amplification of the momentum deposition for low-res simulations +!---------------------------------------- + + use machine , only : kind_phys + use ugwp_common, only : dw2min, velmin + + use ugwp_oro_init, only : rimin, ric, efmin, efmax, & + hpmax, hpmin, sigfaci => sigfac, & + dpmin, minwnd, hminmt, hncrit, & + rlolev, gmax, veleps, factop, & + frc, ce, ceofrc, frmax, cg, & + fdir, mdir, nwdir, & + cdmb, cleff, fcrit_v1, & + n_tofd, ze_tofd, ztop_tofd + + use cires_ugwpv1_module, only : kxw, max_kdis, max_axyz + +! use cires_ugwpv1_sporo, only : oro_spectral_solver + +!---------------------------------------- + implicit none +!---------------------------------------- +! internal parameters +!---------------------------------------- + real(kind=kind_phys), parameter :: sigfac = 3 ! N*hprime height of Subgrid Hill over which SSO-flo + real(kind=kind_phys), parameter :: sigfacs = 0.25 ! M*hprime height is the low boundary of the hill + + real(kind=kind_phys), parameter :: dbmax = 1./3600./12. ! max-Krmtb in hours for u=10 m/s => 20 m/s/day + character(len=8) :: strsolver='pss-1986' ! current operational Ri-solver or 'spect_2020' + + + real(kind=kind_phys) :: gammin = 0.00999999 ! a/b = gammma_min =1% <====> + real(kind=kind_phys), parameter :: nhilmax = 15. ! max number of SSO-hills in grid-box + real(kind=kind_phys), parameter :: sso_min = 3000. ! min-lenghth of the hill, GTOP30 ~dx~1 km + + real(kind=kind_phys), parameter :: nfr = 2.+1. ! power in the emprical Function(Fr/Frc) + real(kind=kind_phys), parameter :: afr = 1. ! (Fr/Frc)^2/(afr +[Fr/Frc]^nfr), Fr = h*mkz + real(kind=kind_phys), parameter :: frnorm =afr+1.0 ! to get cont-ous taulin(Fr=Frc) = tau_nonlin(Fr=Frc) ! + real(kind=kind_phys), parameter :: max_frf =2.0 ! max-value of non-lin flux over the linear at Fr=Frc + + logical, parameter :: do_adjoro = .false. ! +!---------------------------------------- + + integer, intent(in) :: im, km, imx, kdt + integer, intent(in) :: me, master + logical, intent(in) :: do_tofd + + integer, intent(in) :: kpbl(im) ! index for the pbl top layer! + real(kind=kind_phys), intent(in) :: dtp ! time step + real(kind=kind_phys), intent(in) :: cdmbgwd(2) + + real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & + clx4(im,4), theta(im), & + sigmad(im), gammad(im), elvmaxd(im) + + real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, pi, arad, fv + + real(kind=kind_phys), intent(in) :: sgh30(im) + + real(kind=kind_phys), intent(in), dimension(im,km) :: & + u1, v1, t1, q1,del, prsl, prslk, zmet + + real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti + + real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) + real(kind=kind_phys), intent(in) :: sparea(im) + +! +!output -phys-tend +! + real(kind=kind_phys),dimension(im,km),intent(out) :: & + pdvdt, pdudt, pkdis, pdtdt +! output - diag-coorde + real(kind=kind_phys),dimension(im,km),intent(out) :: & + dudt_ogw,dvdt_ogw, dudt_obl,dvdt_obl, dudt_ofd,dvdt_ofd + + real(kind=kind_phys),dimension(im),intent(out) :: dusfc, dvsfc, & + du_ogwcol,dv_ogwcol, du_oblcol,dv_oblcol, du_ofdcol,dv_ofdcol +! + real(kind=kind_phys),dimension(im),intent(out) :: rdxzb + real(kind=kind_phys),dimension(im),intent(out) :: zobl, zogw, zlwb, tau_ogw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +!--------------------------------------------------------------------- +! # of permissible sub-grid orography hills for "any" resolution < 25 +! correction for "elliptical" hills based on shilmin-area =sgrid/25 +! 4.*gamma*b_ell*b_ell >= shilmin +! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min +! gamma_min = 1/4*shilmin/sso_min/sso_min +!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 +! 192: cdmbgwd = 0.5, 2.5 +! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km +! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin +!--------------------------------------------------------------------- +! +! locals vars for SSO +! + + real(kind=kind_phys), dimension(im) :: oa, clx + real(kind=kind_phys), dimension(im) :: sigma, gamma, elvmax ! corrected sigmaD, gammaD, elvmaxD + + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax + + real(kind=kind_phys) :: arhills(im), mkd05_hills(im) ! number of hills in the grid + real(kind=kind_phys) :: taub_kd05(im) +! +! locals mean flow ...etc +! + real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro + real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco +!================== +!mtb +!================== + real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk + real(kind=kind_phys), dimension(im) :: wk, pe, ek, up + + real(kind=kind_phys), dimension(im,km) :: db, ang, uds + + real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr + real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 + real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem + +!================== +! tofd +! some constants now in "use ugwp_oro_init" + "use ugwp_common" +! +!================== + + real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf + real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 + real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 + real(kind=kind_phys), dimension(km) :: up1, vp1, zpm +!================== +! ogw +!================== + real(kind=kind_phys) :: xlingfs + logical :: icrilv(im) +! + real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & + roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 +! + real(kind=kind_phys) :: taup(im,km+1), taud(im,km) + real(kind=kind_phys) :: taub(im), taulin(im), tausat(im), ahdxres(im) + real(kind=kind_phys) :: heff, hsat, hdis + + integer, dimension(im) :: kref, idxzb, ipt, khtop, iwk, izlow +! +! local real scalars +! + real(kind=kind_phys) :: bnv, fr, ri_gw, brvf, fr2 + real(kind=kind_phys) :: tem, tem1, tem2, temc, temv + real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 + real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv + real(kind=kind_phys) :: scork, rscor, hd, fro, sira + real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk + + real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge + + real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 + real(kind=kind_phys) :: belps, aelps, nhills, selps + + real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: pi2, pi2h, rdi, gor, grcp, gocp, gr2, bnv2min + + real(kind=kind_phys) :: cleff_max ! resolution-aware max-wn + real(kind=kind_phys) :: nonh_fact ! non-hydroststic factor 1.-(kx/kz_hh)**2 + real(kind=kind_phys) :: fcrit2 + real(kind=kind_phys) :: fr_func, frnd +! +! +! local integers +! + integer :: kmm1, kmm2, lcap, lcapp1 + integer :: npt, kbps + integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll + integer :: k_mtb, k_zlow, ktrial, klevm1 + integer :: i, j, k +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!=========================== +! First step Check do we have sub-grid hills +! +! +! out-arrays are zreoed in unified_ugwp.F90 +! + do i=1,im + rdxzb(i) = 0.0 + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + ipt(i) = 0 + enddo + +! ---- for lm and gwd calculation points +!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 +!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) +!---- for lm and gwd calculation points +! ccpp-gwdps.f PARAMETER (hpmax=2400.0, hpmin=1.0) parameter (elvmax > hminmt=50.) + + npt = 0 + + do i = 1,im + if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then + npt = npt + 1 + ipt(npt) = i + endif + enddo + + if (npt == 0) then + +! print *, 'orogw_v1 npt = 0 elvmax ', maxval(elvmaxd), hminmt +! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin + + return ! no ogw/mbl calculation done + endif +!=========================== +! scalars from phys-contants added by "CCPP-team" +! by rejecting to use "ugwp_common" +!=========================== + rcpdt = 1.0 / (cpd*dtp) + grav2 = grav + grav +! + rgrav = 1.0/grav + rcpd = 1.0/cpd + rcpd2 = 0.5/cpd + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + pi2 = 2.*pi + pi2h = 0.5*pi + rdi = 1.0/rd + gor = grav/rd + grcp = grav*rcpd + gocp = grcp + gr2 = grav*gor + bnv2min = (pi2/1800.)*(pi2/1800.) ! tau_BV_max = 30 min ! +!=========================== +! Start +! +! initialize gamma and sigma +! + gamma(:) = gammad(:) + sigma(:) = sigmad(:) +! +!======================================================================= +! mtb-blocking sigma_min and dxres => cires_initialize (best way ....) +! + sgrmax = maxval(sparea) ; sgrmin = minval(sparea) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + +! ! GTOP30-arc dx~1Km res-n so sso_hill ~ (2-4)*dx + cleff_max = pi2/max(dsmin/5.,sso_min) ! maxval for kx = 6.28/(dx_min/5. ~2.5 km) for C768 + cleff_max = pi2/dsmin + + hdxres = 0.5*dsmax + + gammin = min(sso_min/hdxres, 1.) + gammin = max(0.1, gammin) + ! sigma-degined as tan(angle) = h/2: L/2= h/L + sigmin = hpmin/hdxres ! min-slope Hmin= 2*hpmin, dxres=Lmax + + + + if ( kdt == -1 .and. me == master) then + print *, ' orogw_v1 scale2 ', cdmbgwd(2) + print *, ' orogw_v1 imx ', imx + print *, ' orogw_v1 gam_min ', gammin + print *, ' orogw_v1 sso_min ', sso_min + print *, ' orogw_v1 gam_min ', gammin + print *, ' orogw_v1 npt number of GRID-cells with hills ', npt + endif + +!============================================================ +! Purpose to adjust oro-specification on the fly +! needs to be done 1-time during init-n for each block +! hprime sigma gamma and grid-length must be "related" +! width_mount_a = hprime/sigma < dxres cannot access dxres +! width_mount_b = width_mount_a * gamma +! +! Sellipse= pi a*b = (width_mount_a)^2 *gamma <= Sarea +! Limiters on "elongated" hills gamma= a/b < gam_min +! Limiters on "longest" hills (b, a) <= sqrt(area) +! +! 0.01=gammin < gamma=a_hill/b_hill < 1 +! hpmin/(dx/2)=sigmin < sigma= hprime/a_ell < 1. +! Nhills = (dx*dy=Sarea)/(pi* a_hill *b_hill) +!============================================================= + + arhills(:) =0. + mkd05_hills(:) =0. + + do j = 1,npt + i = ipt(j) + dxres = sqrt(sparea(i)) + ahdxres(j) = dxres + if (gamma(i) > 1.0) gamma(i) = 1.0 + + gamma(i) = max(gammin, gamma(i)) +! +! min-adjustment: 1) abs(gamma(i)) ; 2) sigres = max(sigmin, sigma(i)) +! + sigres = max(sigmin, sigma(i)) + sigma(i) =sigres + aelps = min( hprime(i)/sigres, dxres) + belps = min(aelps/abs(gamma(i)), dxres) + gamma(i) = aelps/belps + + if (do_adjoro ) then +! +! more adjustments "lengths", gamma and sigma, valid assuminng H=2*hprime H/2 = hprime +! + if (hprime(i) > hdxres*sigres) sigres= hprime(i)/dxres + aelps = min( hprime(i)/sigres, hdxres) + sigma(i) = sigres + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i), dxres) +! +! small-scale "turbulent" oro-hills < sso_min, sso_min_dx = 3km +! will be treated as "circular" elevations +! + if( aelps < sso_min ) then +! +! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm +! + aelps = sso_min + if (belps < sso_min ) then + gamma(i) = 1.0 + belps = aelps*gamma(i) + else + gamma(i) = min(aelps/belps, 1.0) + endif + + sigma(i) = hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + + endif !aelps < sso_min + endif ! ============== (do_adjoro ) + + selps = belps*belps*gamma(i)*pi ! area of the elliptical hill + + nhills = min(nhilmax, sparea(i)/selps) + arhills(j) = max(nhills, 1.0) + +! if (kdt==1 ) write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, belps*1.e-3, sigma(i),gamma(i) + + + enddo + 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) +!======================================================================= +! mtb-blocking : LM-1997; Zadra et al. 2004 ;metoffice dec 2010 H Wells +!======================================================================= + + do i=1,npt + khtop(i) = 2 + idxzb(i) = 0 + enddo + + do k=1,km + do i=1,im + db(i,k) = 0.0 + ang(i,k) = 0.0 + uds(i,k) = 0.0 + enddo + enddo + + kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 + lcap = km ; lcapp1 = lcap + 1 + + cdmb4 = 0.25*cdmb + + do i = 1, npt + j = ipt(i) +! +!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) Max-level of SSO-HILL +! + elvmax(j) = min ( sigfac * hprime(j), hncrit) + izlow(i) = 1 ! surface-level + enddo + + +!=================================================================== +! below khtop-level H= 3*hp, and izlow = 0.5*Hp or the "first" layer +! are used tp estimate "Mean" Flow that interact with SG-HILL +! if sig*HP < Hpbl => GWs-> above PBL +! WRF: ( 1 to max(2*Hp or H_pbl) +! GFS-15/16: OGWs (1 to max(Kpbl+1, or K_dPs=(Ps-Pk=50hPa) ~ 950 mb) +! excitation above Kref +! BLOCKING: ZDOMAIN (1 - Kaver => ELVMAX(J) + sigfac * hp) +!=================================================================== + + + do k = 1, kmm1 + do i = 1, npt + j = ipt(i) + + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) +! +! GFSv15/16: izlow=1 +! elvmax(j)=elvmaxd(J) + sig*hp: if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) khtop(i) = max(khtop(i), k+1 ) +! + + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(i), k+1 ) + if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) + + enddo + enddo +! + do k = 1,km + do i =1,npt + j = ipt(i) + vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) + vtk(i,k) = vtj(i,k) / prslk(j,k) + ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels + taup(i,k) = 0.0 + enddo + enddo +! +! perform ri_n or ri_mf computation for both OGW and OBL +! + do k = 1,kmm1 + do i =1,npt + j = ipt(i) + rdz = 1. / (zmet(j,k+1) - zmet(j,k)) + tem1 = u1(j,k) - u1(j,k+1) + tem2 = v1(j,k) - v1(j,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! +! place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme +! + enddo + enddo + k = 1 + do i = 1, npt + bnv2(i,k) = bnv2(i,k+1) + enddo +! +! level khtop => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) +! + do i = 1, npt + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == khtop(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + pe (i) = 0.0 + ek (i) = 0.0 + bnv2bar(i) = 0.0 +! +! computation of the mean flow char zlow < z < ztop =sigfac*hprime +! + do k = k_zlow, khtop(i)-1 + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo + enddo +! + do i = 1, npt + j = ipt(i) +! +! integrate from ztoph = sigfac*hprime down to zblk if exists +! find ph_blk, dz_blk as introduced in LM-97 and ifs +! + ph_blk =0. + do k = khtop(i), 1, -1 + + phiang = atan2(v1(j,k),u1(j,k)) + phiang = theta(j)*rad_to_deg - phiang + + if ( phiang > pi2h ) phiang = phiang - pi + if ( phiang < -pi2h ) phiang = phiang + pi + ang(i,k) = phiang + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +! + if (idxzb(i) == 0 ) then + dz_blk = zmeti(j,k+1) - zmeti(j,k) + pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk + + up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) + ek(i) = 0.5 * up(i) * up(i) + + ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) + +! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs +! if ( pe(i) >= ek(i) ) then +! --- LM97 + if ( ph_blk >= fcrit_v1 ) then + idxzb(i) = k + zobl (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif + + endif + enddo +! +! fcrit_v1/fr_flow +! + goto 788 +! +! alternative expression for blocking: +! zobl = max(heff*(1. -fcrit_v1/fr_Flow), 0) +! +! + + bnv = sqrt( bnv2bar(i) ) + heff = 2.*min(hprime(j),hpmax) + zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) + ulow(i) = sqrt(max(zw2,dw2min)) + fr = heff*bnv/ulow(i) + zw1 = max(heff*(1. -fcrit_v1/fr), 0.0) + zw2 = zmet(j,2) + + if (fr > fcrit_v1 .and. zw1 > zw2 ) then + do k=2, kmm1 + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) + if (zw1 <= zmetp .and. zw1 >= zmetk) exit + enddo + idxzb(i) = k + zobl (j) = zmet(j, k) + endif +788 continue +! +! --- the drag for the blocked flow +! + if ( idxzb(i) > 0 ) then +! +! (4.16)-ifs description +! + gam2 = gamma(j)*gamma(j) + bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 + cgam = 0.48*gamma(j) + 0.30*gam2 + + do k = idxzb(i)-1, 1, -1 +! +! empirical height dep-nt "blocking" length from LM-1997 +! + zlen = sqrt( (zobl(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) +! +! + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 +! +! cos =1 sin =0 => 1/r= gam zr = 2.-gam +! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam +! + rdem = cosang2 + gam2 * sinang2 + rnom = cosang2*gam2 + sinang2 +! +! metoffice dec 2010 +! correction of H. Wells & A. Zadra for the +! aspect ratio of the hill seen by mean flow +! (1/r , r-inverse below: 2-r) + + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + sigres = max(sigmin, sigma(j)) + + mtbridge = zr * sigres*zlen / hprime(j) +! (4.15)-ifs +! dbtmp = cdmb4 * mtbridge * & +! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) +! (4.16)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) +! +! linear damping due to OBL [1/sec]=[U/L_block_orthogonal] +! more accurate along 2-axes of ellipse, here zr-factor is based on Phillips' analytics +! + db(i,k)= dbtmp * uds(i,k) +! if (db(i,k) > dbmax) print *, ' db > dbmax ', 1./db(i,k)/3600., uds(i,k) + db(i,k)= min(db(i,k), dbmax) + enddo +! + endif + enddo +!............................. +!............................. +! end mtn blocking section +!............................. +!............................. +! +!--- OGW section +! +! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 +! inside "cires_ugwp_initialize.f90" now +! + kmpbl = km / 2 + iwk(1:npt) = 2 +! +! in meto/UK-scheme: +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw +! + do k=3,kmpbl + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb from the surface + enddo + enddo +! +! iwk - adhoc criteria to select ghe ogw-launch level between +! level ~0.4-0.5 km from surface or/and HPBL-top +! +! in all UGWP-schemes: zogw > zobl +! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb +! the top hill can be inside PBL.... if kref = khtop +! + + kbps = 1 + kmps = km + k_mtb = 1 + + do i=1,npt + j = ipt(i) + k_mtb = max(1, idxzb(i)) + ! WRF/GSL: kogw = max(kpbl, ktop=2*var) + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime + kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime +! +! zogw > zobl +! + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above blocking + kbps = max(kbps, kref(i)) + kmps = min(kmps, kref(i)) +! + delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + bnv2bar(i)= 0.0 + enddo +! +! +!====================== we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb +!computation of the mean flow for zobl < z < ztop =sigfac*hprime inb GSL ztop =max(hpbl, ztop) +!===================== + do i = 1,npt + k_mtb = max(1, idxzb(i)) + do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) + if (k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref + vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref + roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo + enddo +! +! orographic asymmetry parameters (oa), and (clx) [Kim & Arakawa Kim & Doyle] +! + do i = 1,npt + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi ! not sure about "+pi" due to "nwdir"-Kim OA/CLX-processing + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) + + clx(i) = clx4(j,mod(nwd-1,4)+1) ! number of "effective" hills in the grid-box KA-95/KD-05 +! +!GSLdrag ->identical to above +! +! wdir = atan2(ubar(i),vbar(i)) + pi +! idir = mod(nint(fdir*wdir),mdir) + 1 +! nwd = nwdir(idir) +! oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) +! ol(i) = ol4(i,mod(nwd-1,4)+1) +! + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control Logic + + ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) + xn(i) = ubar(i) / ulow(i) + yn(i) = vbar(i) / ulow(i) + enddo +! + do k = 1, kmm1 + do i = 1,npt + j = ipt(i) + velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) + enddo + enddo + + do i = 1,npt + velco(i,km) = velco(i,kmm1) + enddo +! +!------------------------------------------------------------------------ +! v0/v1: incorporates modifications for kxridge and heff/hsat +! and employs taulin for fr <=fcrit_v1 +! concept of "clipped" hill if zmtb > 0. is uded to make +! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis +! now it is still used the "single-orowave" along ulow-upwind +! +! in contrast ifs/meto/e-canada employ the 2-orthogonal wave (2otw) schemes of +! it requires "aver angle" and wind projections on axes of ell-hill +! with 2-stresses: taub_a/b as suggested by analytics of Phillips (1984) +!------------------------------------------------------------------------ + + taub(:) = 0. ; taulin(:)= 0. ;taub_kd05 =0. + fcrit2 =fcrit_v1*fcrit_v1 +! +! taub_oro as in KA-95/KD-05 GSL & EMC includes ALL waves (POGWs, Lee-rotors, etc...) +! here taub represents mainly OGWs with nonh_fact = 1. -(kx/kz)**2 +! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered +! + do i = 1,npt + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + + if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac + + if (heff <= 0) cycle + zw1 = ulow(i)/bnv + hsat = fcrit_v1 *zw1 + heff = min(heff, hsat) ! similar hsat-limit in CAM as found in Dec 2020 + + fr = heff/zw1 ! Fr-GSL = Fr * OD -> gamma + + fr = min(fr, frmax) + fr2 = fr*fr + zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) + ! Fr-funct = zw2/(zw2+cg) +! +! [Kim & Doyle, 2005] +! + efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream + efact = min( max(efact,efmin), efmax ) + gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 +! +! !cleff_max(C768 = 6.28/(12.5 km/5.)) ..... +! xlinv(i) = min(coefm * cleff, cleff_max) +! + mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 + + + xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) + + taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) +! +! old: tem = fr2*oc(j) ; gfobnv = gmax * tem / ((tem + cg)*bnv(i)) +! kx =or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge +! + sigres = sigma(j) + inv_b2eff = pi*sigres/heff ! pi2/(2b) + kxridge = pi /ahdxres(i) ! pi2/(2*dx) + xlingfs = max(inv_b2eff, kxridge) +! +! xlinv(i) = max(xlingfs, xlinv(i) ) + + nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 + + if ( nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U +! + taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact + tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact +! +! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => +! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 +! + if ( fr > fcrit_v1 ) then +! + frnd = fr/fcrit_v1 + fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) + taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) + else + taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 + endif + xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 +! + k = max(1, kref(i)-1) + tem = max(velco(i,k)*velco(i,k), dw2min) + scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level Bn2/U2= kz^2 +! +! diagnostics for zogw, tau_ogw +! + zogw(j) = zmeti(j, kref(i) ) + tau_ogw(j) = taub(i) + +! if (kdt == 1) then +! print *, ' tau =', nint(taub(i)*1.e3), ' tkd05 =', nint(taub_kd05(i)*1.e3), 'Fr=', Fr +! print *, ' zogw=', nint(zogw(j)), ' zobl=', nint(zobl(j)) ! nint(mkd05_hills(i)), nint(arhills(i)) +! endif + + enddo +! +!----set up bottom values of stress +! + do i = 1,npt + taup(i, 1:kref(i) ) = taub(i) + enddo +!====================================================== +! +! Having : taub(i)/tau_ogw(j) => solve for OGW-effects +! +!====================================================== + if (strsolver == 'pss-1986') then + +!====================================================== +! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" +! modified by KD05 with the expression (11):below k=kref ??? +! tau(k+1) = tau(k)*Scorer(K+1)/Scorer(K) +! +! in v1-orogw linsatdis of "wam-2017" +! with llwb-mechanism for +! rotational/non-hydrostat ogws important for +! highres-fv3gfs with dx < 10 km +!====================================================== + + do k = kmps, kmm1 ! vertical level loop from min(kref) + kp1 = k + 1 + + do i = 1, npt + if (k >= kref(i)) then + icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) + endif + enddo +! + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + zw1 = max(velco(i,k), velmin) + temv = 1.0 / zw1 +!=============== +! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB ??? only OA >0 +! k >= kref(i) and .... k+1 0. .and. kp1 < kref(i)) then + scork = bnv2(i,k) * temv * temv + rscor = min(1.0, scork / scor(i)) + scor(i) = scork + else + rscor = 1. + endif +!=============== + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface +! xlinv(i)*0.5 + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 + + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv +! +! rim is the "wave"-richardson number byPalmer,Shutts & Swinbank 1986 , PSS-1986 +! + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check Ri-stability to employ the 'dynamical saturation hypothesis' PSS-1986 +! assuming co-existence of Dyn-Ins and Conv-Ins +! + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = zw1 * (2.*sqrt(temc)-temc) / brvf + taup(i,kp1) = tem1 * hd * hd + else + + taup(i,kp1) = taup(i,k) * rscor + endif +! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) + endif ! k >= kref(i)) + enddo ! oro-points + enddo ! do k = kmps, kmm1 vertical level loop +! +! zero momentum deposition at the top model layer: taup(k+1) = taup(k) +! + taup(1:npt,km+1) = taup(1:npt,km) +! +! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud +! + do k = 1,km + do i = 1,npt + zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) +!====================================================================================== +! we estimated "impact" of the single sub-grid hill, we have "arhills" in the grid-box +! 2-estimations of "nhills": 1) geometry-arhills and 2) KDO5 mkd05_hills +! for OBL we used: 1) nhills=Grid_Area/Hill_area +! nhills = max(mkd05_hills(i), arhills(i)) +! Trapped "Lee" downslope wave regimes are not properly modelled: vertical shear +NH/Nonlin +! tau(z) = const => tau(z)/m2(z) = const (empirical mesoscale) +! +! Apply dU/dt-limiter +! +!====================================================================================== +! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hill_area +! apply limiters for OGW tendency +!====================================================================================== + if (abs(zw1) > max_axyz ) then + zw1 = sign(max_axyz, zw1) +! if (kdt <=2 ) then +! print *, ' Hdudt ', nint(max_axyz*1.e5), nint(zw2*1.e5) +! print *, ' Hdudt ', xn(i), yn(i) +! endif + endif + taud(i,k)= zw1 + enddo + enddo + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!------if the gravity wave drag would force a critical line in the +!------layers below sigma=rlolev during the next deltim timestep, +!------then only apply drag until that critical line is reached. +! empirical implementation of the llwb-mechanism: lower level wave breaking +! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb +! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws +!2019: this option limits sensitivity of taux/tauy to variations in "taub" +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then + + if(taud(i,k) /= 0.) then + tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +! dtfac(i) = 1.0 + endif + endif + enddo + enddo +! +!--------- orogw-solver of gfs PSS-1986 is performed + + else + +!----------- orogw-solver of wam2017 out : taup, taud, pkdis + + dtfac(:) = 1.0 + + call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, con_omega, rd, & + del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) + + endif ! oro_linsat - linsatdis-solver for stationary OGWs +! +!---- above orogw-solver of wam2017------------ +! +! tofd as in Beljaars-2004 IFS sep-scale ~5km +! CESM ~ 6km (TMS + OGW/OBL) +! sgh30 = varss of GSL (?) +! ---------------------------------------------- + + if( do_tofd ) then +! +! can scale varss(j) by adjusting filterd oro_turb spectra +! a1-coeff by (Lx_flt_cXXX/Lx_c768)^1.9 +! +! klow = 6.28/10km of Beljaars_etal_2004 and kflt^n1 +! kflt = 6.28/18km +! if ( kdt == 1 .and. me == 0) then +! print *, 'ugwp-v1 do_tofd from surface to ', ztop_tofd +! endif + + do i = 1,npt + j = ipt(i) + zpbl = zmet( j, kpbl(j) ) + + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso + ! GSL-2/limits a) 250 m ; b) var_maxfd =150m + zsurf = zmeti(j,1) + + do k=1,km + zpm(k) = zmet(j,k) + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo + + call ugwp_tofd1d(km, cpd, dtp, sigflt, zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + + do k=1,km + dudt_ofd(j,k) = utofd1(k) + dvdt_ofd(j,k) = vtofd1(k) +! +! add tofd to gw-tendencies +! + pdvdt(j,k) = pdvdt(j,k) + utofd1(k) + pdudt(j,k) = pdudt(j,k) + vtofd1(k) + pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) + enddo +!2018-diag + du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) + dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) + + dusfc(j) = dusfc(j) + du_ofdcol(j) + dvsfc(j) = dvsfc(j) + dv_ofdcol(j) + enddo + endif ! do_tofd + +!-------------------------------------------- +! combine oro-drag effects MB +TOFD + OGWs + diag-3d +!-------------------------------------------- +! + + do k = 1,km + do i = 1,npt + j = ipt(i) +! + eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) +! + if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then +! +! if blocking layers -- no ogws +! + dbim = db(i,k) / (1.+db(i,k)*dtp) + + dudt_obl(j,k) = -dbim * u1(j,k) + dvdt_obl(j,k) = -dbim * v1(j,k) + + pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) + pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) +!2018-diag + du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) + dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) + + dusfc(j) = dusfc(j) + du_oblcol(j) + dvsfc(j) = dvsfc(j) + dv_oblcol(j) + + else +! +! ogw-s above blocking height +! + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) +! + dudt_ogw(j,k) = dtaux + dvdt_ogw(j,k) = dtauy +! + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) + +! + du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) + dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) +! + dusfc(j) = dusfc(j) + du_ogwcol(j) + dvsfc(j) = dvsfc(j) + dv_ogwcol(j) + endif +!============ +! local energy deposition sso-heat due to loss of kinetic energy +!============ + unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) + + enddo + enddo +! dusfc w/o tofd sign as in the era-i, merra and cfsr + do i = 1,npt + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) + du_ogwcol(j) = -rgrav *du_ogwcol (j) + dv_ogwcol(j) = -rgrav *dv_ogwcol (j) + du_oblcol(j) = -rgrav *du_oblcol (j) + dv_oblcol(j) = -rgrav *dv_oblcol (j) + tau_ogw(j) = -rgrav * tau_ogw(j) + du_ofdcol(j) = -rgrav * du_ofdcol(j) + dv_ofdcol(j) = -rgrav * du_ofdcol(j) + enddo + + return + + +!============ debug ------------------------------------------------ + if (kdt <= 2 .and. me == 0) then + print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' +! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' +! print *, maxval(zobl), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' + print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' +! print *, maxval(tau_tofd), ' tau_tofd ' +! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' +! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' + if (maxval(abs(pdudt))*86400. > 100.) then + + print *, maxval(u1), minval(u1), ' u1 gwdps-v1 ' + print *, maxval(v1), minval(v1), ' v1 gwdps-v1 ' + print *, maxval(t1), minval(t1), ' t1 gwdps-v1 ' + print *, maxval(q1), minval(q1), ' q1 gwdps-v1 ' + print *, maxval(del), minval(del), ' del gwdps-v1 ' + print *, maxval(zmet),minval(zmet), 'zmet' + print *, maxval(zmeti),minval(zmeti), 'zmeti' + print *, maxval(prsi), minval(prsi), ' prsi ' + print *, maxval(prsl), minval(prsl), ' prsl ' + print *, maxval(ro), minval(ro), ' ro-dens ' + print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' + print * + do i =1, npt + j= ipt(i) + print *,zogw(j)/hprime(j), zobl(j)/hprime(j), & + zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) +! + enddo + print * + stop + endif + endif + + return + end subroutine orogw_v1 +! +! + subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & + zmid, utofd, vtofd, epstofd, krf_tofd) + + use machine , only : kind_phys + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd +! +! adding the implicit tendency estimate +! + implicit none + integer, intent(in) :: levs + real(kind_phys), intent(in) :: con_cp + real(kind_phys), intent(in) :: dtp + + real(kind_phys), intent(in), dimension(levs) :: u, v, zmid + real(kind_phys), intent(in) :: sigflt, zpbl, zsurf + + real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd + + +! +! locals +! + integer :: i, k + real(kind=kind_phys) :: rcpd2, tofd_mag, tofd_zdep + real(kind_phys) :: unew, vnew, eknew + real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer + real(kind=kind_phys), parameter :: tend_imp = 1. + + + real(kind=kind_phys) :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 + rcpd2 = 0.5/con_cp +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed ~1.5 km +! H_efold = max(2*varss, hpbl) +! H_efold = min(H_efold,1500.) + rzdec = 1.0/zdec + + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res + +! GSL-scheme: varmax_fd, beta_fd ,250. +! var_temp = MIN(varss,varmax_fd) + MAX(0., 0.1*(varss-varmax_fd)) +! var_temp = MIN(var_temp, 250.) +! var_temp = var_temp * var_temp +! +! a12=a1* 0.005363 * 0.0759 * 0.00026615161 +! +! rzdec 1./H_efold +! do k=1,levs +! zmet = zmid(k)-zsurf +! wsp=SQRT(u(k)*u(k) + v(k)*v(k)) ! abs(V) +! zarg = zmet*rzdec +! var_temp = var_temp * a12 * exp(-zarg*sqrt(zarg))*zmet**(-1.2) ! this > 0 +! krf = var_temp * wsp /(1. + var_temp*dtp*wsp) +! utofd(k) = -u(k) *krf +! vtofd(k) = -v(k)/(1. + var_temp*krf +! enddo + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + + ekin = u(k)*u(k) + v(k)*v(k) + + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg * sqrt(zarg)) + + tofd_zdep = zmet ** (-1.2) *ztexp + krf = umag * tofd_mag * tofd_zdep + + if (tend_imp == 1.) then + krf = krf/(1.+krf*dtp) + endif + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + if (tend_imp == 1.) then + unew =u(k)+ utofd(k)*dtp ; vnew =v(k)+ vtofd(k)*dtp + eknew =unew*unew + vnew*vnew + epstofd(k) = rcpd2*(ekin-eknew) + else + epstofd(k) = rcpd2*krf*ekin + endif + ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf ! can be used as addition to the mesoscale blocking + enddo +! + end subroutine ugwp_tofd1d + +end module cires_ugwpv1_oro diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 new file mode 100644 index 000000000..ad8f8090d --- /dev/null +++ b/physics/cires_ugwpv1_solv2.F90 @@ -0,0 +1,1045 @@ +module cires_ugwpv1_solv2 + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- +! call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & +! tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & +! zmet, zmeti,prslk, xlat_d, sinlat, coslat, & +! con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & +! dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + + subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & + tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & + xlatd, sinlat, coslat, & + con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & + pdudt, pdvdt, pdtdt, dked, zngw) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out +! -------------------------------------------------------------------------------- +! + use machine, only : kind_phys + + use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt + + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min +! + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + gw_eff, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +! + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt + + real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + integer, parameter :: ener_norm =0 + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + + real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(im) + real(kind=kind_phys) ,intent(in) :: coslat(im) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling + real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height +! +! +! +! local =========================================================================================== + + real(kind=kind_phys) :: tauabs(im,levs) ! + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux + real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density + real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind + real(kind=kind_phys) :: vint(levs+1) ! meridional wind + real(kind=kind_phys) :: tint(levs+1) ! temp-re + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + real(kind=kind_phys) :: v_zmet(levs+1) + real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax + + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met + real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti + + real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: Qmid, AKT + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + + integer, dimension(levs) :: Anstab + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + real(kind=kind_phys) :: rdci(nwav), rci(nwav) + real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level + real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level +! +! scalars +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + + + real(kind=kind_phys) :: flux_norm ! norm-factor + real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff +! + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode + real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real(kind=kind_phys) :: ucrit_max + real(kind=kind_phys) :: pwrms, ptrms + real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 + +! + real(kind=kind_phys) :: zdelp, zdelm, taud_min + real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: fmode, expdis, fdis + real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real(kind=kind_phys) :: v_wdi, v_wdpc + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + + real(kind=kind_phys) :: kamp, zmetk, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist + real(kind=kind_phys) :: w1, w2, w3, dtdif + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + real(kind=kind_phys) :: rstar, rstar2 + + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + +!-------------------------------------------------------------------------- +! + nslope3 = nslope + 3.0 + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw +! +! test for input fields +! + if (mpi_id == master .and. kdt < -2) then + print *, im, levs, dtp, kdt, ' vay-solv2-v1' + print *, minval(tm), maxval(tm), ' min-max-tm ' + print *, minval(vm), maxval(vm), ' min-max-vm ' + print *, minval(um), maxval(um), ' min-max-um ' + print *, minval(qm), maxval(qm), ' min-max-qm ' + print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' + print *, minval(prsi), maxval(prsi), ' min-max-Pint ' + print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' + print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' + print *, minval(prslk), maxval(prslk), ' min-max-Exner ' + print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' + print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! + endif + + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + suprf(ktop) = kion(levs) + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + + jl =j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + aprsl(1:levs) = prsl(jl,1:levs) +! +! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" +! + do k=1, levs + if (aprsl(k) .lt. psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc= max(ilaunch, 3) + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + +!=====ksrc + + aum(km2:levs) = um(jl,km2:levs) + avm(km2:levs) = vm(jl,km2:levs) + atm(km2:levs) = tm(jl,km2:levs) + aqm(km2:levs) = qm(jl,km2:levs) + azmet(km2:levs) = zmet(jl,km2:levs) + aprsi(km2:levs+1) = prsi(jl,km2:levs+1) + azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) + + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch + + + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 +! +! compute diffusion-based arrays km2:levs +! + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1)-azmeti(jk) + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk) * (1. +fv*aqm(jk)) + tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0 / (tvc+tvm) + rhp_wam = zthm*gor +!interface + uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) + vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) + tint(jk) = 0.5 *(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters +! +! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + + + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) + + akt(jk) = gipr/tvc + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi +! +! project winds at ksrc +! + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1:nazd, km2:ktop) =0. + + do inc=1,nwav + + zcin = zci(inc)*rstar + +! +! integrate (flux(cin) x dcin ) old tau-flux and normalization +! + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) +! +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo + + enddo +! +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + + ekin_norm = 1./snorm_ener + +! taub_src = sigu2 * rho_src * [v_kxw / zms ] +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo + +! copy flux-1 into other azimuths +! -------------------------------- + + + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! -------------------------------- + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) =0.0 +! +! wave_dis(iaz, :) = vueff(jk) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption +! + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + +! +! rotational cut-off +! + kzw2 = (bn2(jkp)-wdop2)/Cdf2 +! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds_sat = kxw*Cdf1*rhp2/kzw3 +!krad, kvg, kion, ktg + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc + +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 =0. + endif +! expdis =1.0 + + fdis = fmode*expdis*wave_act(inc,iaz) +!============================================================================== +! +! Saturated Fluxes and Energy: Spectral and Dicrete Modes +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! +! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) + +! +! +! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) +! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 +! [fden_bn(jkp)] = Pa/dc +! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] + + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] +! +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif +!---------------------------------------------------------------------------- +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +!---------------------------------------------------------------------------- + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if(zdep > 0.0 ) then +! subs on sat-limit + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer + else +! assign dis-ve flux + flux(inc,iaz) = fdis + endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif +! +! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" +! + if ( azmeti(jkp) .ge. zsp_gw) then + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + exp_sponge = exp(-ze1) +! +! additional sponge +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 +! +! sum for given (jk, iaz) all active "wave" contributions +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff + + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! +! compute wind and temp-re rms +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + +! -------------- + enddo ! end Azimuth do-loop + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) + ze1=max(dked_min, tx1) + ze2=min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) +! + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif +! + + do jk=ksrc+1,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +!maxdtdt= dked_max * bnfix2 +! + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo +!---------------------------------------------------------------------------------- +! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur +! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt +! can check "stability" in the column and "add" ktur-estimation +! to suppress instability as needed so dked = dked_gw + ktur_ric +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) + + do jk=ksrc,levs + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + +! +! Thermal budget qmid = qheat + qcool +! + do jk=ksrc+1,levs + ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = qmid(jk)*rcpd + dked(jl, jk) = dktur(jk) + enddo +! +! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" +! from the surface/launch-gw to the "top" +! +! +! update by source function X(t+dt) = X(t) + dtp * dXdt +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! +! diagnose turb-profile using "stability-check" relying on the free-atm diffusion +! sc2 = 30m x 30m +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1./ze1 + + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) +! +! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur +! +! update of dked = dked_gw + k_turb_mf +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + +! +! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability +! + if (knob_ugwp_dokdis == 2) then + + do jk=km1,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! +! k instead Jk +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! +! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs +! + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo +! +! compute "smoothed" tendencies by molecular + GW-eddy diffusions +! + do k=ksrc,levs-1 +! +! final updates of tendencies and diffusion +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + + enddo ! J-loop +! + RETURN + +!================================= + if (kdt ==1 .and. mpi_id == master) then +! + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif +!================================= + return + end subroutine cires_ugwpv1_ngw_solv2 + + +end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 new file mode 100644 index 000000000..98eca419e --- /dev/null +++ b/physics/cires_ugwpv1_sporo.F90 @@ -0,0 +1,353 @@ + + subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & + dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & + grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + sinlat, xlatd, taup, taud, pkdis) +! + USE MACHINE , ONLY : kind_phys +! + implicit none + + integer, intent(in) :: im, levs + integer, intent(in) :: npt + integer, intent(in) :: kdt, me, master + integer, intent(in) :: kref(im), ipt(im) + + real(kind=kind_phys), intent(in) :: dtp, dxres + real(kind=kind_phys), intent(in) :: taub(im) + + real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) + real(kind=kind_phys), intent(in), dimension(im) :: sigma, & + hprime, gamma, theta + + real(kind=kind_phys), intent(in), dimension(im) :: xn, yn + + real(kind=kind_phys), intent(in), dimension(im, levs) :: & + u1, v1, t1, bn2, rho, prsl, del + real(kind=kind_phys), intent(in) :: grav, omega, con_rd + + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi +! +! out : taup, taud, pkdis +! + real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup + real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud + real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis +! +! multiwave oro-spectra +! locals +! + + integer, parameter :: nworo = 30 + real(kind=kind_phys), parameter :: fc_flag = 0.0 + real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 + real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin + real(kind=kind_phys), parameter :: kedmin = 1.e-3 + real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: Linsat2 =0.5 + real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. + real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 + real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) + real(kind=kind_phys), parameter :: kx_slope= -5./3. + real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps + real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin + + real(kind=kind_phys) :: akx(nworo), cxoro(nworo), akx2(nworo) + real(kind=kind_phys) :: aspkx(nworo), c2f2(nworo), cdf2(nworo) + real(kind=kind_phys) :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) + real(kind=kind_phys) :: tau_kx(nworo),taub_kx(nworo) + + real(kind=kind_phys), dimension(nworo, levs+1) :: wrms, akzw + + real(kind=kind_phys) :: tauz(levs+1), rms_wind(levs+1) + real(kind=kind_phys) :: wave_act(nworo,levs+1) + + real(kind=kind_phys) :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint + real(kind=kind_phys) :: rayf, kturb + real(kind=kind_phys) :: uz, bv, bv2,kxsp, fcor2, cf2 + + real(kind=kind_phys) :: fdis + real(kind=kind_phys) :: wfdm, wfdt, wfim, wfit + real(kind=kind_phys) :: betadis, betam, betat, kds, cx, rhofac + real(kind=kind_phys) :: etwk, etws, tauk, cx2sat + real(kind=kind_phys) :: cdf1, tau_norm +! +! mean flow +! + real(kind=kind_phys), dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi + real(kind=kind_phys) :: belps, aelps, nhills, selps + integer :: i, j, k, isp, iw + integer :: nw, nzi, ksrc + + + taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 + tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 + nw = nworo + nzi = levs+1 + + do iw = 1, nw +! !kxw = 0.25/(dxres)*iw + kxw = kxmin+(iw-1)*dkx + akx(iw) = kxw + akx2(iw) = kxw*kxw + aspkx(iw) = kxw ** (kx_slope) + tau_kx(iw) = aspkx(iw)*dkx + enddo + + tau_norm = sum(tau_kx) + tau_kx(:) = tau_kx(:)/tau_norm + + if (kdt == 1) then + write(6,771) maxval(tau_kx)*maxval(taub)*1.e3, minval(tau_kx), maxval(tau_kx) + endif +771 format( ' oro_spectral_solver ', 3(2x,F8.3)) +! +! main loop over oro-points +! + do i =1, npt + j = ipt(i) + +! +! estimate "nhills" => stochastic choices for OGWs +! + if (taub(i) > 0.) then +! +! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) +! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) +! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx +! + wave_act(1:nw, 1:levs+1) = 1.0 + ksrc = kref(i) + tauz(1:ksrc) = taub(i) + taub_kx(1:nw) = tau_kx(1:nw) * taub(i) + wkdis(:,:) = kedmin + + call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & + & prsi(j,:), prsL(j,:), grav, con_rd, & + & del(j,:), rho(i,:), & + & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & + & xn(i), yn(i)) + + fcor2 = (2*omega*sinlat(j))*(2*omega*sinlat(j))*fc_flag + + k = ksrc + + bv2 = bn2(i,k) + uz = uzi(k) !u1(j,ksrc)*xn(i)+v1(j,ksrc)*yn(i)! + kturb = ktur(k) + rayf = kalp(k) + rhoint = rhoi(k) + dzmet = dzi(k) + kzw = max(sqrt(bv2)/max(cxmin, uz), mkzmin) +! +! specify oro-kx spectra and related variables k=ksrc +! + do iw = 1, nw + kxw = akx(iw) + cxoro(iw) = 0.0 - uz + c2f2(iw) = fcor2/akx2(iw) + wrms(iw,k)= taub_kx(iw)/rhoint*kzw/kxw + tau_sp(iw, k) = taub_kx(iw) +! +! + if (cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0. ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) then + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off + else + kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) + kzw = sqrt(kzw2) + akzw(iw,k)= kzw + wrms(iw,k)= taub_kx(iw)/rhoint * kzw/kxw + endif + endif + enddo ! nw-spectral loop +! +! defined abobe, k = ksrc: akx(nworo), cxoro(nworo), tau_sp(ksrc, nworo) +! propagate upward multiwave-spectra are filtered by dissipation & instability +! +! tau_sp(:,ksrc+1:levs+1) = tau_sp(:, ksrc) + do k= ksrc+1, levs + uz = uzi(k) + bv2 =bn2(i,k) + bv = sqrt(bv2) + rayf = kalp(k) + rhoint= rhoi(k) + dzmet = dzi(k) + rhofac = rhoi(k-1)/rhoi(k) + + do iw = 1, nworo +! + if (wave_act(iw, k-1) <= 0.0) cycle + cxoro(iw)= 0.0 - uz + if ( cxoro(iw) > cxmin) then + wave_act(iw,k:levs+1) = 0.0 ! crit-level + else + cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) + if ( cdf2(iw) < cxmin2) wave_act(iw,k:levs+1) = 0.0 + endif + if ( wave_act(iw,k) <= 0.0) cycle +! +! upward propagation +! + kzw2 = Bv2/Cdf2(iw) - akx2(iw) + + if (kzw2 < mkz2min) then + wave_act(iw,k:levs+1) = 0.0 + else +! +! upward propagation w/o reflection +! + kxw = akx(iw) + kzw = sqrt(kzw2) + akzw(iw,k) = kzw + kzw3 = kzw2*kzw + + cx = cxoro(iw) + betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) + betaM = 1.0 / (1.0+betadis) + betaT = 1.0 - BetaM + kds = wkdis(iw,k-1) + + etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) + + kturb = ktur(k)+pkdis(j,k-1) + wfiM = kturb*kzw2 +rayf + wfiT = wfiM ! do updates with Pr-numbers Kv/Kt + cdf1 = sqrt(Cdf2(iw)) + wfdM = wfiM/(kxw*Cdf1)*BetaM + wfdT = wfiT/(kxw*Cdf1)*BetaT + kzi = 2.*kzw*(wfdM+wfdT)*dzmet + Fdis = exp(-kzi) + + etwk = etws*Fdis + Cx2sat = Linsat2*Cdf2(iw) + + if (etwk > cx2sat) then + Kds = kxw*Cdf1*rhp2/kzw3 + etwk = cx2sat + wfiM = kds*kzw2 + wfdM = wfiM/(kxw*Cdf1) + kzi = 2.*kzw*(wfdm + wfdm)*dzmet + etwk = cx2sat*exp(-kzi) + endif +! if( lat(j) eq 40.5 ) then stop + wkdis(iw,k) = kds + wrms(iw,k) = etwk + tauk = etwk*kxw/kzw + tau_sp(iw,k) = tauk *rhoint + if ( tau_sp(iw,k) > tau_sp(iw,k-1)) & + tau_sp(iw,k) = tau_sp(iw,k-1) + + ENDIF ! upward + ENDDO ! spectral + +!......... do spectral sum of rms, wkdis, tau + + tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) + rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau + + if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax + + ENDDO ! k=ksrc+1, levs + + k = ksrc + tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) + tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc + + pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) + rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) + tauz(levs+1) = tauz(levs) + taup(i, 1:levs+1) = tauz(1:levs+1) + + do k=ksrc, levs + taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) +! +! limiters can be applied to avoid "large" wave accelerations +! +! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 +! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) + enddo + endif ! taub > 0 + enddo ! oro-points (i, j, ipt) +! + end subroutine oro_spectral_solver +!------------------------------------------------------------- +! +! define mean flow and dissipation for OGW-kx spectrum +! +!------------------------------------------------------------- + subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & + & grav, con_rd, & + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + use machine , only : kind_phys + use ugwp_common , only : velmin, dw2min + implicit none + + integer :: nz, nzi + real(kind=kind_phys), dimension(nz ) :: u1, v1, t1, delp, rho, pmid + real(kind=kind_phys), dimension(nz ) :: bn2 ! define at the interfaces + real(kind=kind_phys), dimension(nz+1) :: pint + real(kind=kind_phys) :: xn, yn + real(kind=kind_phys),intent(in) :: grav, con_rd +! output + + real(kind=kind_phys), dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp + +! locals + integer :: i, j, k + real(kind=kind_phys) :: ui, vi, ti, uz, vz, shr2, rdz, kamp + real(kind=kind_phys) :: zgrow, zmet, rdpm, ritur, kmol, w1 + real(kind=kind_phys) :: rgrav, rdi +! paremeters + real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 + real(kind=kind_phys), parameter :: rhps=1.0/hps + real(kind=kind_phys), parameter :: h4= 0.25/hps + real(kind=kind_phys), parameter :: rimin = 1.0/8.0, kedmin = 0.01 + real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 + real(kind=kind_phys), parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb + kalp(1:nzi) = 2.e-7 ! radiative damping + + rgrav = 1.0/grav + rdi = 1.0/con_rd + + do k=2, nz + rdpm = grav/(pmid(k-1)-pmid(k)) + ui = .5*(u1(k-1)+u1(k)) + vi = .5*(v1(k-1)+v1(k)) + uzi(k) = Ui*xn + Vi*yn + ti = .5*(t1(k-1)+t1(k)) + rhoi(k) = rdi*pint(k)/ti + rdz = rdpm *rhoi(k) + dzi(k) = 1./rdz + uz = u1(k)-u1(k-1) + vz = v1(k)-v1(k-1) + shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) + zmet = -hps*alog(pint(k)*rpspa) + zgrow = exp(zmet*h4) + kmol = 2.e-5*exp(zmet*rhps)+kedmin + ritur = max(bn2(k)/shr2, rimin) + kamp = sqrt(shr2)*lsc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur(k) = kamp * w1 * w1 +kmol + enddo + + k = 1 + uzi(k) = uzi(k+1) + ktur(k) = ktur(k+1) + rhoi(k) = rdi*pint(k)/t1(k+1) + dzi(k) = rgrav*delp(k)/rhoi(k) + + k = nzi + uzi(k) = uzi(k-1) + ktur(k) = ktur(k-1) + rhoi(k) = rhoi(k-1)*.5 + dzi(k) = dzi(k-1) + + end subroutine oro_meanflow + diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 new file mode 100644 index 000000000..db95a4f87 --- /dev/null +++ b/physics/cires_ugwpv1_triggers.F90 @@ -0,0 +1,446 @@ +module cires_ugwpv1_triggers + + use machine, only: kind_phys + +contains + + +! +! +! +!>\ingroup cires_ugwp_run +!> @{ +!! +!! + subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) +!================= +! V0: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + integer :: i + +! +! if-lat +! + do i=1, im + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = 0.10 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_tamp_v0 +! + + +! + subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) +!================= +! V1: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +!================= + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + integer :: i + +! +! if-lat +! + do i=1, im + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = 0.10 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_tamp_v1 +! + subroutine slat_geos5_2020(im, tau_amp, xlatdeg, tau_gw) +!================================================================= +! modified for FV3GFS-127L/C96 QBO-experiments +! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) +!================================================================ + implicit none + integer :: im + real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) + real(kind=kind_phys) :: latdeg, flat_gw, tem + real(kind=kind_phys), parameter :: fampqbo = 1.25 ! 1.5 + real(kind=kind_phys), parameter :: famp60S = 1.0 ! 1.5 + real(kind=kind_phys), parameter :: famp60N = 1.0 ! 1.0 + real(kind=kind_phys), parameter :: famp30 = 0.25 ! 0.4 + + real(kind=kind_phys), parameter :: swid15 = 12.5 + real(kind=kind_phys), parameter :: swid60S = 30.0 ! 40 + real(kind=kind_phys), parameter :: swid60N = 25.0 ! 30 + integer :: i +! +! +! + do i=1, im + + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / swid15 + flat_gw = fampqbo * exp(-tem * tem) + if (latdeg <= 3.0) flat_gw = fampqbo + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then + flat_gw = famp30 + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60N* exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60N + flat_gw = famp60N * exp(- tem * tem) + endif + + if (xlatdeg(i) <= -31.0) then +! + if (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = famp60S * exp(- tem * tem) + endif + if (latdeg >= 60.0) then + tem = (latdeg-60.0) /swid60S + flat_gw = famp60S * exp(- tem * tem) + endif + + endif + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5_2020 + + + subroutine slat_geos5(im, xlatdeg, tau_gw) + +!================= +! +! WAM: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* +! +!================= + implicit none + integer :: im + real(kind=kind_phys) :: xlatdeg(im) + real(kind=kind_phys) :: tau_gw(im) + real(kind=kind_phys) :: latdeg + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys) :: trop_gw, flat_gw + integer :: i +! +! if-lat +! + trop_gw = 0.75 + do i=1, im + latdeg = xlatdeg(i) + if (-15.3 < latdeg .and. latdeg < 15.3) then + flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) + if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw + else if (latdeg > -31. .and. latdeg <= -15.3) then + flat_gw = 0.10 + else if (latdeg < 31. .and. latdeg >= 15.3) then + flat_gw = 0.10 + else if (latdeg > -60. .and. latdeg <= -31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg < 60. .and. latdeg >= 31.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else if (latdeg <= -60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + else if (latdeg >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + end if + tau_gw(i) = tau_amp*flat_gw + enddo +! + end subroutine slat_geos5 + + subroutine init_nazdir(con_pi, naz, xaz, yaz) + implicit none + real(kind=kind_phys) :: con_pi + integer :: naz + real(kind=kind_phys), dimension(naz) :: xaz, yaz + integer :: idir + real(kind=kind_phys) :: phic, drad + real(kind=kind_phys) :: pi2 + pi2 = 2.0*con_pi + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir +!========================================================================= +! Below subroutine that can be activated after "testing" and extra-work" +!========================================================================= + subroutine emc_modulation(im , levs, ntke, tau_ngw, cdmb3, cdmb4, dtp, & + q_tke, dqdt_tke, del, rain) + + integer, intent(in) :: im , levs, ntke + real(kind=kind_phys), intent(in) :: cdmb3, cdmb4, dtp + real(kind=kind_phys), intent(in) :: rain(im) + real(kind=kind_phys), intent(inout) :: tau_ngw(im) + real(kind=kind_phys), intent(in), dimension(im,levs) :: q_tke, dqdt_tke, del + +! locals + + + real(kind=kind_phys) :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1, tke + + +!============ +! +! below the "EMC-proposal" in May 2019 without rigorous tests reported elsewhere +! can be eliminated due to "lack" of validations and +! in GFSv16 cdmbgwd(3) =1.0 and the next if-loop is "cosmetic" proposal +! +!============ + if (1.0-cdmb3 > 1.0e-6) then + rfac = 86400000. / dtp !??? +! +! in operations cdmbgwd(3) = 1 in GFSv16, and code below is not executed +! + if (cdmb4 > 0.0) then + do i=1,im + turb_fac = 0.0 + if (ntke > 0) then + tem = 0.0 + do k=1,(levs+levs)/3 ! ???? + tke = q_tke(i,k) + dqdt_tke(i,k) * dtp + turb_fac = turb_fac + del(i,k) * tke + tem = tem + del(i,k) + enddo + turb_fac = turb_fac / tem + endif + tx1 = cdmb4*min(10.0, max(turb_fac,rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) * cdmb3 !???? + enddo + endif + endif + end subroutine emc_modulation + + +!=============================================== +! +! Spontaneous GW triggers by dynamical inbalances (OKW, fronts/jets, and convection) +! not activated due to "limited" set of GFS-physics +! statein-type ( needs horizontal gradients of winds and temperature, humodity) +! +!=============================================== + subroutine get_spectra_tau_convgw & + (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) +! +! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function +! + integer :: nw, im, levs + integer,dimension(im,3) :: icld + real(kind=kind_phys), dimension(im, levs) :: dcheat, scheat + real(kind=kind_phys), dimension(im) :: precip, xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! +! locals + real(kind=kind_phys), parameter :: precip_max = 100. ! mm/day + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + + integer :: i, k, klow, ktop, kmid + real(kind=kind_phys) :: dtot, dmax, daver +! + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + do i=1, im + klow = icld(i,1) + ktop = icld(i,2) + kmid= icld(i,3) + if (klow == -99 .and. ktop == -99) then + cycle + else + klev(i) = ktop + k = klow + klev(i) = k + dmax = abs(dcheat(i,k) + scheat(i,k)) + do k=klow+1, ktop + dtot =abs(dcheat(i,k) + scheat(i,k)) + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! +! klev as max( dcheat(i,k) + scheat) +! vertical width of conv-heating +! +! counts/triiger=1 & taub(i) +! + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_amp* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! +! + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 + enddo + +! with info on precip/clouds/dc_heat create Bulk +! taub(im), klev(im) +! +! print *, ' get_spectra_tau_convgw ' + end subroutine get_spectra_tau_convgw +! + subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real(kind=kind_phys), dimension(im, levs) :: trig_fgf +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 3.5e-3 ! 3.5 mPa + real(kind=kind_phys), parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: fnorm, tau_min + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1.0 / float(kwidth) + tau_min = tau_amp*fnorm + do i=1, im +! +! only trop-c fjets so find max(trig_fgf) => klev +! use abs-values to scale tau_amp +! + + k = klow + klev(i) = k + dmax = abs(trig_fgf(i,k)) + kex = 0 + if (dmax >= tlim_fgf) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_fgf(i,k)) + if (dtot >= tlim_fgf) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo + + if (dmax .ge. tlim_fgf) then + nf_src = nf_src +1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo +! +! print *, ' get_spectra_tau_nstgw ' + call Slat_geos5(im, xlatd, taub) + nf_src =im + do i=1, im + if_src(i) = 1 + klev(i) = 127-45 ! FV3-127L + enddo +! + end subroutine get_spectra_tau_nstgw +! + subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) + integer :: nw, im, levs + real(kind=kind_phys), dimension(im, levs) :: trig_okw +! real(kind=kind_phys), dimension(im, levs+1) :: pint + real(kind=kind_phys), dimension(im) :: xlatd, sinlat, coslat + real(kind=kind_phys), dimension(im) :: taub + integer, dimension(im) :: klev, if_src + integer :: nf_src +! locals + real(kind=kind_phys), parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch GWs should scale-dependent + real(kind=kind_phys), parameter :: tau_amp = 35.e-3 ! 35 mPa + real(kind=kind_phys), parameter :: pmax = 750.e2, pmin = 100.e2 + integer, parameter :: klow =127-92, ktop=127-45 ! for FV3-127L + integer, parameter :: kwidth = ktop-klow+1 + integer :: i, k, kex + real(kind=kind_phys) :: dtot, dmax, daver + real(kind=kind_phys) :: fnorm, tau_min + + nf_src = 0 + if_src(1:im) = 0 + taub(1:im) = 0.0 + fnorm = 1./float(kwidth) + tau_min = tau_amp*fnorm + print *, ' get_spectra_tau_okwgw ' + do i=1, im + k = klow + klev(i) = k + dmax = abs(trig_okw(i,k)) + kex = 0 + if (dmax >= tlim_okw) kex = kex+1 + do k=klow+1, ktop + dtot = abs(trig_okw(i,k)) + if (dtot >= tlim_fgf ) kex = kex+1 + if ( dtot > dmax) then + klev(i) = k + dmax = dtot + endif + enddo +! + if (dmax >= tlim_okw) then + nf_src = nf_src + 1 + if_src(i) = 1 + taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) + endif + + enddo + print *, ' get_spectra_tau_okwgw ' + end subroutine get_spectra_tau_okw + +end module cires_ugwpv1_triggers diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 new file mode 100644 index 000000000..252838ca1 --- /dev/null +++ b/physics/ugwpv1_gsldrag.F90 @@ -0,0 +1,671 @@ +!> \file ugwpv1_gsldrag.F90 +!! This file combines three gravity wave drag schemes under one ("ugwpv1_gsldrag") suite: +!! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: +!! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f +!! b) the v0 cires ugwp non-stationary GWD scheme +!! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: +!! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales +!! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) +!! b) small-scale gravity wave drag scheme -- active typically in stable PBL at horizontal grid resolutions down to ~1km +!! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) +!! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km +!! (Beljaars et al, 2004 \cite beljaars_et_al_2004) +!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) +!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers +!! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics +!! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. +!! Unified Formalism: +!! 1. GW Sources: Stochastic and physics based mechanisms for GW-excitations in the lower atmosphere, calibrated by the high-res analyses/forecasts, and observations (3 types of GW sources: orography, convection, fronts/jets). +!! 2. GW Propagation: Unified solver for "propagation, dissipation and breaking" excited from all type of GW sources. +!! 3. GW Effects: Unified representation of GW impacts on the "resolved" flow for all sources (energy-balanced schemes for momentum, heat and mixing). +!! https://www.weather.gov/media/sti/nggps/Presentations%202017/02%20NGGPS_VYUDIN_2017_.pdf +!! +!! The ugwpv1_gsldrag scheme is activated by gwd_opt = 2 in the namelist. +!! The choice of schemes is activated at runtime by the following namelist options (boolean): +!! NA do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD is not active (NA) +!! NA do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale OGWD and blocking +!! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale OGWD +!! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag +!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD +!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only +!! do_ugwp_v1_w_gsldrag -- activates V1 CIRES UGWP scheme with orographic drag of GSL +!! Note that only one "large-scale" scheme can be activated at a time. +!! + +module ugwpv1_gsldrag + + use machine, only: kind_phys + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 +! use cires_ugwp1_sporo, only: oro_spectral_solver + + use drag_suite, only: drag_suite_run + +! use cires_ugwpv1_triggers, only: get_spectra_tau_convgw, get_spectra_tau_okw, get_spectra_tau_nstgw +! use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 +! use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 +! use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 +! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize +! use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp +! use gwdps, only: gwdps_run + + implicit none + + private + + public ugwpv1_gsldrag_init, ugwpv1_gsldrag_run, ugwpv1_gsldrag_finalize + + logical :: is_initialized = .False. + +contains + +! ------------------------------------------------------------------------ +! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 +! ------------------------------------------------------------------------ +!>@brief The subroutine initializes the unified UGWP +!> \section arg_table_ugwpv1_gsldrag_init Argument Table +!! \htmlinclude ugwpv1_gsldrag_init.html +!! +! ----------------------------------------------------------------------- +! + subroutine ugwpv1_gsldrag_init ( & + me, master, nlunit, input_nml_file, logunit, & + fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & + con_pi, con_rerth, con_p0, & + do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) + +!---- initialization of unified_ugwp + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + character(len=*), intent (in) :: input_nml_file(:) + integer, intent (in) :: logunit + integer, intent(in) :: jdat(8) + integer, intent (in) :: lonr + integer, intent (in) :: levs + integer, intent (in) :: latr + real(kind=kind_phys), intent (in) :: ak(levs+1), bk(levs+1) + real(kind=kind_phys), intent (in) :: dtp + + real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth + logical, intent (in) :: do_ugwp + + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, & + do_ugwp_v1_orog_only,do_ugwp_v1_w_gsldrag + + character(len=*), intent (in) :: fn_nml2 + !character(len=*), parameter :: fn_nml='input.nml' + + integer :: ios + logical :: exists + real :: dxsg + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!============================================= +! 3 cases for ORO-schemes + NGWs: +! gwd_opt => "1 and 2, 3, 22, 33' +! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 +! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp +!============================================= + ! Test to make sure that at most only one large-scale/blocking + ! orographic drag scheme is chosen + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & + do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & + (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & + do_ugwp_v1_orog_only)) .or. & + (do_gsl_drag_ls_bl.and.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: Only one large-scale& + &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& + &do_gsl_drag_ls_bl,do_ugwp_v1 or & + &do_ugwp_v1_orog_only) can be chosen" + errflg = 1 + return + + end if + + if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then + print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 + print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only + write(errmsg,'(*(a))') " the CIRES CCPP-suite does not & + support schemes " + errflg = 1 + return + endif + if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then + + print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag + print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only + print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl + write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & + support but has Logic error" + errflg = 1 + return + endif + if (is_initialized) return + + if ( do_ugwp_v1 ) then + call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & + con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & + con_p0, dtp, errmsg, errflg) + end if + + if (me == master) then + print *, ' ccpp: ugwpv1_gsldrag_init ' + + print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 + print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl + print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss + print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd + + print *, ' ccpp: ugwpv1_gsldrag_init ' + endif + + is_initialized = .true. + + + end subroutine ugwpv1_gsldrag_init + + +! ----------------------------------------------------------------------- +! finalize of ugwpv1_gsldrag (_finalize) +! ----------------------------------------------------------------------- + +!>@brief The subroutine finalizes the CIRES UGWP + +!> \section arg_table_ugwpv1_gsldrag_finalize Argument Table +!! \htmlinclude ugwpv1_gsldrag_finalize.html +!! + + subroutine ugwpv1_gsldrag_finalize(errmsg, errflg) + + implicit none +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call cires_ugwp_dealloc + + is_initialized = .false. + + end subroutine ugwpv1_gsldrag_finalize + + +! ----------------------------------------------------------------------- +! originally from ugwp_driver_v0.f +! driver of cires_ugwp (_driver) +! ----------------------------------------------------------------------- +! driver is called after pbl & before chem-parameterizations +! ----------------------------------------------------------------------- +! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re +! ----------------------------------------------------------------------- +!>@brief These subroutines and modules execute the CIRES UGWP Version 0 +!>\defgroup ugwpv1_gsldrag_run Unified Gravity Wave Physics General Algorithm +!> @{ +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! +!! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. +!! +!> \section arg_table_ugwpv1_gsldrag_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_run.html +!! +!> \section gen_ugwpv1_gsldrag CIRES UGWP Scheme General Algorithm +!! @{ + subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & + ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & + do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & + gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & + con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & + nmtvr, hprime, oc, theta, sigma, gamma, elvmax, clx, oa4, & + varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & + rain, br1, hpbl, kpbl, slmsk, & + ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, del, tau_amf, & + dudt_ogw, dvdt_ogw, dtdt_sso, du_ogwcol, dv_ogwcol, & + dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & + dudt_oss, dvdt_oss, du_osscol, dv_osscol, & + dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & + tau_ogw, tau_ngw, tau_oss, & + zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & + ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & + lprnt, ipr, errmsg, errflg) + +! old data: jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & +! cap: dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf +! +! +!######################################################################## +! Attention New Arrays and Names must be ADDED inside +! +! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta +! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 +!######################################################################## +![ccpp-table-properties] +! name = GFS_interstitial_type +! type = ddt +!######################################################################## +! +! + implicit none + +! Preference use (im,levs) rather than (:,:) to avoid memory-leaks +! order description control-logical +! other in-variables +! out-variables +! local-variables +! unified diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 +! +! +! interface variables + logical, intent(in) :: ldiag3d, lssav + logical, intent(in) :: flag_for_gwd_generic_tend + logical, intent(in) :: lprnt + + integer, intent(in) :: ipr + +! flags for choosing combination of GW drag schemes to run + + logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd + logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp + logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes + + integer, intent(in) :: me, master, im, levs, ntrac,lonr + real(kind=kind_phys), intent(in) :: dtp, fhzero + integer, intent(in) :: kdt, jdat(8) + +! SSO parameters and variables + integer, intent(in) :: gwd_opt + integer, intent(in) :: nmtvr + real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! in gsl_drag + + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma + + real(kind=kind_phys), intent(in), dimension(im) :: elvmax + real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 + + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx + real(kind=kind_phys), intent(in), dimension(im, 4) :: oa4ss,ol4ss + +!===== +!ccpp-style passing constants +!===== + real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & + con_rv, con_rerth, con_fvirt +! grids + + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + +! State vars + PBL/slmsk +rain + + real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil + real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii + real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 + integer, intent(in), dimension(im) :: kpbl + + real(kind=kind_phys), intent(in), dimension(im) :: rain + real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk +! +! moved to GFS_phys_time_vary +! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau +! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau + real(kind=kind_phys), intent(in), dimension(im) :: tau_amf + +!Output (optional): + + real(kind=kind_phys), intent(out), dimension(im) :: & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol +! +! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) +! du_ngwcol, dv_ngwcol + + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: tau_ogw, tau_ngw, tau_oss + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_sso, dtdt_ngw, dtdt_gw + + real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw +! +! + real(kind=kind_phys), intent(inout), dimension(im, levs) :: dudt, dvdt, dtdt + +! +! These arrays are only allocated if ldiag=.true. +! +! Version of COORDE updated by CCPP-dev for time-aver +! + real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw + + + + real(kind=kind_phys), intent(out), dimension(im) :: rdxzb ! for stoch phys. mtb-level + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + integer :: i, k + real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis +!------------ +! +! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init +! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa +! +! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 +!------------ +! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 + +! switches that activate impact of OGWs and NGWs + +! integer :: nmtvr_temp + + real(kind=kind_phys) :: inv_g + + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers + real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces + + +! ugwp_v1 local variables + + integer :: y4, month, day, ddd_ugwp, curdate, curday + +! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 +! diagnostics for wind and temp rms to compare with space-borne data and metrics +! in the Middle atmosphere: 20-110 km ( not active in CCPP-style, oct 2020) +! real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) + + + ! Initialize CCPP error handling variables + + errmsg = '' + errflg = 0 + +! 1) ORO stationary GWs +! ------------------ +! +! for all oro-suites can uze geo-meters having "hpbl" +! + inv_g = 1./con_g +! +! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust +! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" +! + zmeti = phii*inv_g + zmet = phil*inv_g + +!=============================================================== +! ORO-diag + + dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. + dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. + + dusfcg (:) = 0. ; dvsfcg(:) =0. + + du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. + du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. + +! + dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. + +! ngw+ogw - diag + + dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. +! source fluxes + + tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. + +! launch layers + + zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. +!=============================================================== +! Accumulated tendencies due to 3-SSO schemes (all ORO-physics) +! ogw + obl +oss +ofd ..... no explicit "lee wave trapping" +!=============================================================== + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo +! +! ------------------ +! +! Also zero all ORO diag-c arrays to avoid "special ifs and zeros" +! like old GFS-ORO gwdps_run has limited diagnostics +! +! ------------------ + + ! Run the appropriate large-scale (large-scale GWD + blocking) scheme + ! Note: In case of GSL drag_suite, this includes ss and tofd + + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd & + .or. do_ugwp_v1_w_gsldrag) then +! +! the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : +! +! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd +! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol +! dusfcg, dvsfcg +! gsd_diss_ht_opt =0 => Pdtdt = bl+ls +(Pdtdt=0) +! + call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & + ugrs,vgrs,tgrs,q1, & + kpbl,prsi,del,prsl,prslk,phii,phil,dtp, & + kdt,hprime,oc,oa4,clx,varss,oc1ss,oa4ss, & + ol4ss,theta,sigma,gamma,elvmax, & + dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl, & + dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd, & + dusfcg, dvsfcg, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol, & + slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & + con_fvirt,con_pi,lonr, & + cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & + do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & + errmsg,errflg) +! +! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol +! + if (kdt <= 2 .and. me == master) then + print *, ' unified drag_suite_run ', kdt + print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 + print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 + +! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 + +! if (gwd_opt == 22 .or. gwd_opt == 33) then +! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 +! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 +! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 +! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 +! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 +! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 +! endif + endif + + else +! +! not gsldrag scheme for example "do_ugwp_v1_orog_only" +! + + if ( do_ugwp_v1_orog_only ) then +! +! for TOFD we use now "varss" of GSL-drag /not sgh30=abs(oro-oro_f)/ +! only sum of integrated ORO+GW effects (dusfcg and dvsfcg) = sum(ogw + obl + oss*0 + ofd + ngw) +! +! OROGW_V1 introduce "orchestration" between OGW-effects and Mountain Blocking +! it starts to examines options for the Scale-Aware (SA)formulation of SSO-effects +! if ( me == master .and. kdt == 1) print *, ' bf orogw_v1 nmtvr=', nmtvr, ' do_tofd=', do_tofd + + if (gwd_opt ==1 )sgh30 = 0.15*hprime ! portion of the mesoscale SSO (~[oro_unfilt -oro_filt) + if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run + + call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & + con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & + con_rerth, con_fvirt,xlat_d, sinlat, coslat, area, & + cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & + sigma, gamma, elvmax, sgh30, kpbl, ugrs, & + vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & + Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & + zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & + dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_ofdcol, dv_ofdcol, errmsg,errflg ) +! +! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms +! +! + if (kdt <= 2 .and. me == master) then + + print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr + print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 + print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 + print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 + print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 + print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 + endif + +! pdudt = 0.0*pdudt ; pdvdt = 0.0*pdvdt ; pdtdt = 0. + + end if +! +! GFS-style diag dt3dt(:.:, 1:14) +! + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + Pdudt(i,k)*dtp + ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + Pdvdt(i,k)*dtp + ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + Pdtdt(i,k)*dtp + enddo + enddo + endif + ENDIF ! +! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Begin non-stationary GW schemes +! ugwp_v1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (do_ugwp_v1) then + +!================================================================== +! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) +! +! updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs +!================================================================== + + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) +! if (me == master) then +! print *, ' ugwpv1 forcing ', maxval(tau_ngw), minval(tau_ngw) +! print *, ' ugwpv1 forcing tamp_mpa ', tamp_mpa +! endif + y4 = jdat(1); month = jdat(2); day = jdat(3) +! +! hour = jdat(5) +! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. +! fhour = (kdt-1)*dtp/3600. +! fhrday = fhour/24. - nint(fhour/24.) + + + call calendar_ugwp(y4, month, day, ddd_ugwp) + curdate = y4*1000 + ddd_ugwp +! + call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & + tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) + + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & + tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + + + if (me == master .and. kdt <= 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' +! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + + print *, ' ugwp_v1 ', kdt + print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 + print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 + print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 + + + endif + + + end if ! do_ugwp_v1 + +! +! GFS-style diag dt3dt(:.:, 1:14) time-averaged +! + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then + do k=1,levs + do i=1,im + ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtp + ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtp + ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtp + enddo + enddo + endif + +! +! get total sso-OGW + NGW +! + dudt_gw = Pdudt +dudt_ngw + dvdt_gw = Pdvdt +dvdt_ngw + dtdt_gw = Pdtdt +dtdt_ngw + kdis_gw = Pkdis +kdis_ngw +! +! add to previous phys-tendencies +! ?-accumulation of GFS ( pbl + gw =0 rf should be taken out from physics, inside FV3-dycore) + + dudt = dudt + dudt_ngw + dvdt = dvdt + dvdt_ngw + dtdt = dtdt + dtdt_ngw + + end subroutine ugwpv1_gsldrag_run +!! @} +!>@} +end module ugwpv1_gsldrag diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta new file mode 100644 index 000000000..73d717f78 --- /dev/null +++ b/physics/ugwpv1_gsldrag.meta @@ -0,0 +1,1265 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag + type = scheme + dependencies = machine.F,drag_suite.F90 + dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 + dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for opening namelist file + units = none + dimensions = () + type = integer + intent = in + optional = F +[input_nml_file] + standard_name = namelist_filename_for_internal_file_reads + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_of_namelist_filename_for_internal_file_reads) + type = character + kind = len=* + intent = in + optional = F +[logunit] + standard_name = iounit_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in + optional = F +[fn_nml2] + standard_name = namelist_filename + long_name = namelist filename for ugwp + units = none + dimensions = () + type = character + kind = len=* + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[latr] + standard_name = number_of_latitude_points + long_name = number of global points in y-dir (j) along the meridian + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ak] + standard_name = a_parameter_of_the_hybrid_coordinate + long_name = a parameter for sigma pressure level calculations + units = Pa + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[bk] + standard_name = b_parameter_of_the_hybrid_coordinate + long_name = b parameter for sigma pressure level calculations + units = none + dimensions = (number_of_vertical_layers_for_radiation_calculations_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_p0] + standard_name = standard_atmospheric_pressure + long_name = standard atmospheric pressure + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0] + standard_name = do_ugwp_v0 + long_name = flag to activate ver 0 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v0_orog_only] + standard_name = do_ugwp_v0_orog_only + long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_w_gsldrag] + standard_name = do_ugwp_v1_w_gsldrag + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_run + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[lonr] + standard_name = number_of_equatorial_longitude_points + long_name = number of global points in x-dir (i) along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fhzero] + standard_name = hours_between_clearing_of_diagnostic_buckets + long_name = hours between clearing of diagnostic buckets + units = h + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_gravity_wave_drag_tendency + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ls_bl] + standard_name = do_gsl_drag_ls_bl + long_name = flag to activate GSL drag suite - large-scale GWD and blocking + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_ss] + standard_name = do_gsl_drag_ss + long_name = flag to activate GSL drag suite - small-scale GWD + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_gsl_drag_tofd] + standard_name = do_gsl_drag_tofd + long_name = flag to activate GSL drag suite - turb orog form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_orog_only] + standard_name = do_ugwp_v1_orog_only + long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_ugwp_v1_w_gsldrag] + standard_name = do_ugwp_v1_w_gsldrag + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + type = logical + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[do_tofd] + standard_name = turb_oro_form_drag_flag + long_name = flag for turbulent orographic form drag + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplication factors for cdmb and gwd + units = none + dimensions = (4) + type = real + kind = kind_phys + intent = in + optional = F +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rerth] + standard_name = radius_of_earth + long_name = radius of earth + units = m + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of topographic variables in GWD + units = count + dimensions = () + type = integer + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degree + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[varss] + standard_name = standard_deviation_of_subgrid_orography_small_scale + long_name = standard deviation of subgrid orography small scale + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oc1ss] + standard_name = convexity_of_subgrid_orography_small_scale + long_name = convexity of subgrid orography small scale + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oa4ss] + standard_name = asymmetry_of_subgrid_orography_small_scale + long_name = asymmetry of subgrid orography small scale + units = none + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4ss] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height_small_scale + long_name = horizontal fraction of grid box covered by sso higher than critical height small scale + units = frac + dimensions = (horizontal_loop_extent,4) + type = real + kind = kind_phys + intent = in + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = grid latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sinlat] + standard_name = sine_of_latitude + long_name = sine of the grid latitude + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[coslat] + standard_name = cosine_of_latitude + long_name = cosine of the grid latitude + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between midlayers + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tau_amf] + standard_name = ngw_abs_momentum_flux + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ogw] + standard_name = y_momentum_tendency_from_meso_scale_ogw + long_name = y momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_sso] + standard_name = tendency_of_air_temperature_due_to_sso + long_name = air temperature tendency due to subgrid-scale orography + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ogwcol] + standard_name = integrated_x_momentum_flux_from_meso_scale_ogw + long_name = integrated x momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ogwcol] + standard_name = integrated_y_momentum_flux_from_meso_scale_ogw + long_name = integrated y momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_obl] + standard_name = x_momentum_tendency_from_blocking_drag_vy + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_obl] + standard_name = y_momentum_tendency_from_blocking_drag_vy + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_oblcol] + standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_oblcol] + standard_name = integrated_y_momentum_flux_from_blocking_drag_vy + long_name = integrated y momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_oss] + standard_name = x_momentum_tendency_from_small_scale_gwd_vy + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_oss] + standard_name = y_momentum_tendency_from_small_scale_gwd_vy + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_osscol] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd_vy + long_name = integrated x momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_osscol] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd_vy + long_name = integrated y momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ofd] + standard_name = x_momentum_tendency_from_form_drag_vy + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ofd] + standard_name = y_momentum_tendency_from_form_drag_vy + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[du_ofdcol] + standard_name = integrated_x_momentum_flux_from_form_drag_vy + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dv_ofdcol] + standard_name = integrated_y_momentum_flux_from_form_drag_vy + long_name = integrated y momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_ngw] + standard_name = tendency_of_x_wind_due_to_ngw + long_name = zonal wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_ngw] + standard_name = tendency_of_y_wind_due_to_ngw + long_name = meridional wind tendency due to non-stationary GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_ngw] + standard_name = tendency_of_air_temperature_due_to_ngw + long_name = air temperature tendency due to non-stationary GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_ngw] + standard_name = eddy_mixing_due_to_ngw + long_name = eddy mixing due to non-stationary GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_allgw + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_allgw + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_allgw + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kdis_gw] + standard_name = eddy_mixing_due_to_allgw + long_name = eddy mixing due to all GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tau_oss] + standard_name = instantaneous_momentum_flux_due_to_sso + long_name = momentum flux or stress due to SSO including OBL-OSS-OFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity waves + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zobl] + standard_name = height_of_mountain_blocking_v1 + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zngw] + standard_name = height_of_launch_level_of_nonsta_gravity_wave + long_name = height of launch level of non-stationary GWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F + intent = out + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[ldu3dt_ogw] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in x wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ogw] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in y wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ogw] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldu3dt_ngw] + standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in x wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldv3dt_ngw] + standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag + long_name = cumulative change in y wind due to convective gravity wave drag + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ldt3dt_ngw] + standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag + long_name = cumulative change in temperature due to convective gravity wave drag + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + + diff --git a/physics/ugwpv1_gsldrag_post.F90 b/physics/ugwpv1_gsldrag_post.F90 new file mode 100644 index 000000000..1d8813f65 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.F90 @@ -0,0 +1,107 @@ +!> \file ugwpv1_gsldrag_post.F90 +!! This file contains +module ugwpv1_gsldrag_post + +contains + +!>\defgroup ugwpv1_gsldrag_post ugwpv1_gsldrag Scheme Post +!! @{ + + subroutine ugwpv1_gsldrag_post_init () + end subroutine ugwpv1_gsldrag_post_init + +!>@brief The subroutine initializes the unified UGWP + +!> \section arg_table_ugwpv1_gsldrag_post_run Argument Table +!! \htmlinclude ugwpv1_gsldrag_post_run.html +!! + + + + subroutine ugwpv1_gsldrag_post_run ( im, levs, & + ldiag_ugwp, dtf, & + dudt_gw, dvdt_gw, dtdt_gw, du_ofdcol, du_oblcol, tau_ogw, & + tau_ngw, zobl, zlwb, zogw, dudt_obl, dudt_ofd, dudt_ogw, & + tot_zmtb, tot_zlwb, tot_zogw, & + tot_tofd, tot_mtb, tot_ogw, tot_ngw, & + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in) :: dtf + logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics + + real(kind=kind_phys), intent(in), dimension(im) :: zobl, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(im) :: du_ofdcol, tau_ogw, du_oblcol, tau_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw + + real(kind=kind_phys), intent(in), dimension(im,levs) :: dtdt_gw, dudt_gw, dvdt_gw + real(kind=kind_phys), intent(in), dimension(im,levs) :: dudt_obl, dudt_ogw, dudt_ofd + real(kind=kind_phys), intent(inout), dimension(im,levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + + real(kind=kind_phys), intent(inout), dimension(im,levs) :: dtdt, dudt, dvdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +! post creates the "time-averaged" diagnostics" +! + + if (ldiag_ugwp) then + tot_zmtb = tot_zmtb + dtf *zobl + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw + + tot_tofd = tot_tofd + dtf *du_ofdcol + tot_mtb = tot_mtb + dtf *du_oblcol + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw + + du3dt_mtb = du3dt_mtb + dtf *dudt_obl + du3dt_tms = du3dt_tms + dtf *dudt_ofd + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *dudt_gw + dv3dt_ngw = dv3dt_ngw + dtf *dvdt_gw + endif + +!===================================================================== +! Updates inside the ugwpv1_gsldrag.F90 +! +! dtdt = dtdt + dtdt_gw +! dudt = dudt + dudt_gw +! dvdt = dvdt + dvdt_gw +! +! "post" may also create the "time-averaged" diagnostics" +! +! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then +! do k=1,levs +! do i=1,im +! ldu3dt_ngw(i,k) = ldu3dt_ngw(i,k) + dudt_ngw(i,k)*dtf +! ldv3dt_ngw(i,k) = ldv3dt_ngw(i,k) + dvdt_ngw(i,k)*dtf +! ldt3dt_ngw(i,k) = ldt3dt_ngw(i,k) + dtdt_ngw(i,k)*dtf +! +! ldu3dt_ogw(i,k) = ldu3dt_ogw(i,k) + dudt_ogw(i,k)*dtf +! ldv3dt_ogw(i,k) = ldv3dt_ogw(i,k) + dvdt_ogw(i,k)*dtf +! ldt3dt_ogw(i,k) = ldt3dt_ogw(i,k) + dtdt_ogw(i,k)*dtf +! enddo +! enddo +! endif +! +!===================================================================== + end subroutine ugwpv1_gsldrag_post_run + + subroutine ugwpv1_gsldrag_post_finalize () + end subroutine ugwpv1_gsldrag_post_finalize + +!! @} +end module ugwpv1_gsldrag_post diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta new file mode 100644 index 000000000..9ed76d6e8 --- /dev/null +++ b/physics/ugwpv1_gsldrag_post.meta @@ -0,0 +1,321 @@ +[ccpp-table-properties] + name = ugwpv1_gsldrag_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_allgw + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_allgw + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_allgw + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[du_oblcol] + standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[du_ofdcol] + standard_name = integrated_x_momentum_flux_from_form_drag_vy + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ogw] + standard_name = instantaneous_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = momentum flux or stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tau_ngw] + standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave + long_name = momentum flux or stress due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zobl] + standard_name = height_of_mountain_blocking_v1 + long_name = height of mountain blocking drag_v1 + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zlwb] + standard_name = height_of_low_level_wave_breaking + long_name = height of low level wave breaking for OGWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zogw] + standard_name = height_of_launch_level_of_orographic_gravity_wave + long_name = height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_obl] + standard_name = x_momentum_tendency_from_blocking_drag_vy + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ofd] + standard_name = x_momentum_tendency_from_form_drag_vy + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt_ogw] + standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tot_zmtb] + standard_name = time_integral_of_height_of_mountain_blocking + long_name = time integral of height of mountain blocking drag + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zlwb] + standard_name = time_integral_of_height_of_low_level_wave_breaking + long_name = time integral of height of drag due to low level wave breaking + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_zogw] + standard_name = time_integral_of_height_of_launch_level_of_orographic_gravity_wave + long_name = time integral of height of launch level of orographic gravity wave + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_tofd] + standard_name = time_integral_of_momentum_flux_due_to_turbulent_orographic_form_drag + long_name = time integral of momentum flux due to TOFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_mtb] + standard_name = time_integral_of_momentum_flux_due_to_mountain_blocking_drag + long_name = time integral of momentum flux due to mountain blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ogw] + standard_name = time_integral_of_momentum_flux_due_to_orographic_gravity_wave_drag + long_name = time integral of momentum flux due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tot_ngw] + standard_name = time_integral_of_momentum_flux_due_to_nonstationary_gravity_wave + long_name = time integral of momentum flux due to nonstationary gravity waves + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ngw] + standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in x wind due to NGW + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt_ngw] + standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in y wind due to NGW + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = ugwpv1_gsldrag_post_finalize + type = scheme + diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 5c0604f86..220acb42c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -244,8 +244,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, integer, intent(in) :: gwd_opt integer, intent(in), dimension(im) :: kpbl real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma - real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss,dx - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + real(kind=kind_phys), intent(in), dimension(im) :: varss,oc1ss, dx + +!vay-nov 2020 + real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss + logical, intent(in) :: flag_for_gwd_generic_tend ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS real(kind=kind_phys), intent(inout), dimension(im) :: elvmax @@ -315,12 +318,11 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im) :: sgh30 real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis - real(kind=kind_phys), dimension(im, levs) :: ed_dudt, ed_dvdt, ed_dtdt - ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init + real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. - real(kind=kind_phys), parameter :: fw1_tau=1.0 + integer :: nmtvr_temp real(kind=kind_phys), dimension(:,:), allocatable :: tke @@ -331,23 +333,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces - - ! ugwp_v1 local variables - integer :: y4, month, day, ddd_ugwp, curdate, curday - integer :: hour - real(kind=kind_phys) :: hcurdate, hcurday, fhour, fhrday - integer :: kdtrest - integer :: curday_ugwp - integer :: curday_save=20150101 - logical :: first_qbo=.true. - real :: hcurday_save =20150101.00 - save first_qbo, curday_save, hcurday_save - - - ! ugwp_v1 temporary (local) diagnostic variables from cires_ugwp_solv2_v1 - real(kind=kind_phys) :: tauabs(im,levs), wrms(im,levs), trms(im,levs) - - ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -388,7 +373,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, sgh30 = abs(oro - oro_uf) ! w/o orographic effects else - sgh30 = 0. + sgh30 = varss endif inv_g = 1./con_g @@ -543,26 +528,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. endif -#if 0 - !============================================================================= - ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving - ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" - !============================================================================= - ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies - !------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, q1, & - del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) - gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked - gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked - gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked -#endif if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs @@ -577,160 +542,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, end if ! do_ugwp_v0 - ! - ! ugwp_v1 non-stationary GW drag - ! - if (do_ugwp_v1) then - -! -------- -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) - - y4 = jdat(1); month = jdat(2); day = jdat(3) ; hour = jdat(5) - - ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. - fhour = (kdt-1)*dtp/3600. - fhrday = fhour/24. - nint(fhour/24.) - fhour = fhrday*24. - - call calendar_ugwp(y4, month, day, ddd_ugwp) - curdate = y4*1000 + ddd_ugwp - curday = y4*10000 + month*100 + day - hcurdate = float(curdate) + fhrday - hcurday = float(curday) + fhrday -! - if (mod(fhour,fhzero) == 0 .or. first_qbo) then - - ! call tau_limb_advance(me, master, im, levs, ddd_ugwp, curdate, & - ! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) - - if (first_qbo) kdtrest = kdt - first_qbo = .false. - curday_save = curday - hcurday_save= hcurday - endif - - ! tau_ngw = fw1_tau*tau_ngw + tau_sat*(1.-fw1_tau) - -! goto 111 -! if (mod(fhour,fhzero) == 0 .or. first_qbo) then - -! call tau_qbo_advance(me, master, im, levs, ddd_ugwp, curdate, & -! j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, j1_qbo, j2_qbo, & -! ddy_j1qbo, ddy_j2qbo, tau_sat, tau_qbo, uqbo, ax_qbo, kdt ) - - -! if (me == master) then -! print *, ' curday_save first_qbo ', curday, curday_save, kdt -! print *, ' hcurdays ', hcurdate, float(hour)/24. -! print *, jdat(5), jdat(6), jdat(7), (kdt-1)*dtp/3600., ' calendar ' -!! print *, ' curday curday_ugwp first_qbo ', hcurday, first_qbo -!! print *, ' vay_tau-limb U' , maxval(uqbo), minval(uqbo) -!! print *, ' vay_tau-limb TS' , maxval(tau_sat), minval(tau_sat) -!! print *, ' vay_tau-limb TQ' , maxval(tau_qbo), minval(tau_qbo) -! endif - - -! if (first_qbo) kdtrest = kdt -! first_qbo = .false. -! curday_save = curday -! hcurday_save= hcurday -! endif - - - - -! if (mod(kdt, 720) == 0 .and. me == master ) then -! print *, ' vay_qbo_U' , maxval(uqbo), minval(uqbo) , kdt -! endif - -! wqbo = dtp/taurel -! do k =1, levs -!! sdexpz = wqbo*vert_qbo(k) -! sdexpz = 0.25*vert_qbo(k) -! do i=1, im -!! if (dexpy(i) > 0.0) then -! dforc = 0.25 -!! ugrs(i,k) = ugrs(i,k)*(1.-dforc) + dforc*uqbo(i,levs+1-k) -!! tgrs(i,k) = tgrs(i,k)*(1.-dforc) + dforc*tqbo(i,levs+1-k) -!! endif -! enddo -! enddo - -! 111 continue - - - call cires_ugwp_solv2_v1(im, levs, dtp, & - tgrs, ugrs, vgrs, q1, prsl, prsi, & - zmet, zmeti,prslk, xlat_d, sinlat, coslat, & - con_g, con_cp, con_rd, con_rv, con_omega, & - con_pi, con_fvirt, & - gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & - tauabs, wrms, trms, tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - endif - - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - !+(uqbo(i,levs+1-k)-ugrs(i,k))/21600. - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) ! + pogw*Pkdis(i,k) - enddo - enddo - - - - - if (pogw == 0.0) then -! zmtb = 0.; zogw =0. - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 - endif - -! return - -!============================================================================= -! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving -! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" -!============================================================================= -! -! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies -!------------------------------------------------------------------------------ - -! ed_dudt(:,:) = 0.0 ; ed_dvdt(:,:) = 0.0 ; ed_dtdt(:,:) = 0.0 - - - -! call edmix_ugwp_v1(im, levs, dtp, & -! tgrs, ugrs, vgrs, q1, del, & -! prsl, prsi, phil, prslk, & -! gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & -! ed_dudt, ed_dvdt, ed_dTdt, -! me, master, kdt ) - -! do k=1,levs -! do i=1,im -! gw_dtdt(i,k) = gw_dtdt(i,k) + ed_dtdt(i,k)*pked -! gw_dvdt(i,k) = gw_dvdt(i,k) + ed_dvdt(i,k)*pked -! gw_dudt(i,k) = gw_dudt(i,k) + ed_dudt(i,k)*pked -! enddo -! enddo - - - end if ! do_ugwp_v1 - - end subroutine unified_ugwp_run !! @} !>@} From 9ebf28b79f34517647d63d63acfda5dd9ba47441 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Mon, 11 Jan 2021 03:24:22 -0500 Subject: [PATCH 50/67] physics/cires_tauamf_data.F90 ugwp-data --- physics/cires_tauamf_data.F90 | 256 ++++++++++++++++++++++++++++++++++ 1 file changed, 256 insertions(+) create mode 100644 physics/cires_tauamf_data.F90 diff --git a/physics/cires_tauamf_data.F90 b/physics/cires_tauamf_data.F90 new file mode 100644 index 000000000..5a0296d4c --- /dev/null +++ b/physics/cires_tauamf_data.F90 @@ -0,0 +1,256 @@ +module cires_tauamf_data + + use machine, only: kind_phys +!........................................................................................... +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +!........................................................................................... +implicit none + + integer :: ntau_d1y, ntau_d2t + real(kind=kind_phys), allocatable :: ugwp_taulat(:) + real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) + logical :: flag_alloctau = .false. + character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' + + public :: read_tau_amf, cires_indx_ugwp, tau_amf_interp + +contains + + subroutine read_tau_amf(me, master, errmsg, errflg) + + use netcdf + integer, intent(in) :: me, master + integer :: ncid, iernc, vid, dimid, status + integer :: k + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! Tabulated sources +! + + iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) + + if(iernc.ne.0) then + write(errmsg,'(*(a))') "read_tau_amf: cannot open file_limb_tab data-file ", & + trim(ugwp_taufile) + print *, 'cannot open ugwp-v1 tau-file=',trim(ugwp_taufile) + errflg = 1 + return + else + + + status = nf90_inq_dimid(ncid, "lat", DimID) +! if (status /= nf90_noerr) call handle_err(status) +! + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d1y ) + + status = nf90_inq_dimid(ncid, "days", DimID) + status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) + + if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd of tau_ngw ugwp-v1 ' + if (ntau_d2t .le. 0 .or. ntau_d1y .le. 0) then + print *, 'ugwp-v1 tau-file=', trim(ugwp_taufile) + print *, ' ugwp-v1: ', 'ntau_d2t=',ntau_d2t, 'ntau_d2t=',ntau_d1y + stop + endif + + if (.not.allocated(ugwp_taulat)) allocate (ugwp_taulat(ntau_d1y )) + if (.not.allocated(days_limb)) allocate (days_limb(ntau_d2t)) + if (.not.allocated(tau_limb)) allocate (tau_limb(ntau_d1y, ntau_d2t )) + + iernc=nf90_inq_varid( ncid, 'DAYS', vid ) + iernc= nf90_get_var( ncid, vid, days_limb) + iernc=nf90_inq_varid( ncid, 'LATS', vid ) + iernc= nf90_get_var( ncid, vid, ugwp_taulat) + iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) + iernc= nf90_get_var( ncid, vid, tau_limb) + + iernc=nf90_close(ncid) + + endif + + end subroutine read_tau_amf + + subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau) + + use machine, only: kind_phys + + implicit none +! +! + integer, intent(in) :: npts, me, master + real(kind=kind_phys) , dimension(npts), intent(in) :: dlat + + integer, dimension(npts), intent(inout) :: j1_tau, j2_tau + real(kind=kind_phys) , dimension(npts), intent(inout) :: w1_j1tau, w2_j2tau + +!locals + + integer :: i,j, j1, j2 + + + +! +! weights for tau_limb w1_j1tau, w2_j2tau +! + + + if (me == master) then + print * + print *, ' ugwp_tabulated files input ' +! print *, ' ugwp_taulat ', ugwp_taulat +! print *, ' days ', days_limb + print *, ' TAU-ugwp ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 + print * + endif +! + do j=1,npts + j2_tau(j) = ntau_d1y + do i=1,ntau_d1y + if (dlat(j) < ugwp_taulat(i)) then + j2_tau(j) = i + exit + endif + enddo + + + j2_tau(j) = min(j2_tau(j),ntau_d1y) + j1_tau(j) = max(j2_tau(j)-1,1) + + if (j1_tau(j) /= j2_tau(j) ) then + w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & + / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) + + else + w2_j2tau(j) = 1.0 + endif + w1_j1tau(j) = 1.0 - w2_j2tau(j) + + enddo + + return + + if (me == master ) then + +223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) + print *, 'ugwp-v1 indx_ugwp ', size(dlat), ' npts ', npts + do j=1,npts + j1 = j1_tau(j) + j2 = j2_tau(j) + write(6,223) j, ugwp_taulat(j1), dlat(j), ugwp_taulat(j2), w2_j2tau(j), w1_j1tau(j) + enddo + print * + + endif + end subroutine cires_indx_ugwp + + subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) + + use machine, only: kind_phys + implicit none + +!input + integer, intent(in) :: me, master + integer, intent(in) :: im, idate(4) + real(kind=kind_phys), intent(in) :: fhour + + real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1, ddy_j2 + integer , intent(in), dimension(im) :: j1_tau,j2_tau +!ouput + real(kind=kind_phys), dimension(im) :: tau_ddd +!locals + + integer :: i, j1, j2, it1, it2 , iday + integer :: ddd + real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd +! +! define day of year ddd ..... from the old-fashioned "GFS-style" +! having idate[4] ??? +! + call gfs_idate_calendar(idate, fhour, ddd, fddd) + + it1 = 2 + do iday=1, ntau_d2t + if (fddd .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo + + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' Error in time-interpolation for tau_amf_interp ' + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + print *, ' Error in time-interpolation see cires_tauamf_data.F90 ' + stop + endif + + w2 = (fddd-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 + + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1(i)+tau_limb(j2, it1)*ddy_j2(i) + tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) + tau_ddd(i) = tx1*w1 + w2*tx2 + enddo + +! if(me == master) then +! print *, ' tau_amf_interp : ', fddd, ddd , ' DOY ' +! print *, ' tau_amf_maxmin : ' , maxval(tau_ddd)*1.e3, minval(tau_ddd)*1.e3 +! endif + + end subroutine tau_amf_interp + + subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) + + use machine, only: kind_phys + implicit none +! input + integer, intent(in) :: idate(4) + real(kind=kind_phys), intent(in) :: fhour +!out + integer, intent(out) :: ddd + real(kind=kind_phys), intent(out) :: fddd +! +!locals +! + real(kind=kind_phys) :: rinc(5), rjday + integer :: jdow, jdoy, jday + real(4) :: rinc4(5) + integer :: w3kindreal, w3kindint + + integer :: iw3jdn + integer :: jd1, jddd + + integer idat(8),jdat(8) + + + idat(1:8) = 0 + idat(1) = idate(4) + idat(2) = idate(2) + idat(3) = idate(3) + idat(5) = idate(1) + rinc(1:5) = 0. + rinc(2) = fhour +! get jdat + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4 = rinc + call w3movdat(rinc4, idat,jdat) + else + call w3movdat(rinc, idat,jdat) + endif + +!! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow, ddd, jday) + fddd = float(ddd) + jdat(5) / 24. + + end subroutine gfs_idate_calendar + +end module cires_tauamf_data From e7cd3069417df6e9b51cca1a38e5c6ab3aeccceb Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Sun, 17 Jan 2021 01:38:41 +0000 Subject: [PATCH 51/67] Added new logical flag do_ugwp_v0_nst_only which allows non-stationary drag from ugwp_v0 to be run with GSL drag suite --- physics/unified_ugwp.F90 | 47 ++++++++++++++++++++++++++++----------- physics/unified_ugwp.meta | 24 ++++++++++++++++++++ 2 files changed, 58 insertions(+), 13 deletions(-) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 5c0604f86..a07e85202 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -25,6 +25,7 @@ !! The choice of schemes is activated at runtime by the following namelist options (boolean): !! do_ugwp_v0 -- activates V0 CIRES UGWP scheme - both orographic and non-stationary GWD !! do_ugwp_v0_orog_only -- activates V0 CIRES UGWP scheme - orographic GWD only +!! do_ugwp_v0_nst_only -- activates V0 CIRES UGWP scheme - non-stationary GWD only !! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking !! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD !! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag @@ -75,9 +76,9 @@ module unified_ugwp subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & - do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & - do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only, errmsg, errflg) + do_ugwp_v0, do_ugwp_v0_orog_only, do_ugwp_v0_nst_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + do_ugwp_v1, do_ugwp_v1_orog_only, errmsg, errflg) !---- initialization of unified_ugwp implicit none @@ -98,6 +99,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth logical, intent (in) :: do_ugwp logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only @@ -136,11 +138,23 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & end if + ! Test to make sure that if ugwp_v0 non-stationary-only is selected that + ! ugwp_v1 is not also selected + if ( do_ugwp_v0_nst_only .and. (do_ugwp_v1.or.do_ugwp_v1_orog_only) ) then + + write(errmsg,'(*(a))') "Logic error: do_ugwp_v0_nst_only can only be & + &selected if both do_ugwp_v1 and do_ugwp_v1_orog_only are not & + &selected" + errflg = 1 + return + + end if + if (is_initialized) return - if ( do_ugwp_v0 ) then + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) then ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) if (cdmbgwd(3) > 0.0) then call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & @@ -148,7 +162,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) else write(errmsg,'(*(a))') "Logic error: cires_ugwp_mod_init called but & - &do_ugwp_v0 is true and cdmbgwd(3) <= 0" + &do_ugwp_v0 or do_ugwp_v0_nst_only is true and cdmbgwd(3) <= 0" errflg = 1 return end if @@ -177,11 +191,13 @@ end subroutine unified_ugwp_init !! \htmlinclude unified_ugwp_finalize.html !! - subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) + subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & + do_ugwp_v1,errmsg, errflg) implicit none ! - logical, intent (in) :: do_ugwp_v0, do_ugwp_v1 + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only, & + do_ugwp_v1 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -191,7 +207,7 @@ subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v1,errmsg, errflg) if (.not.is_initialized) return - if ( do_ugwp_v0 ) call cires_ugwp_mod_finalize() + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwp_mod_finalize() if ( do_ugwp_v1 ) call cires_ugwp_finalize() @@ -234,8 +250,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & - do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + do_ugwp_v1, do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) implicit none @@ -303,6 +319,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! flags for choosing combination of GW drag schemes to run logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only @@ -408,7 +425,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, end if - if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only.or.do_ugwp_v0_nst_only ) then do k=1,levs do i=1,im @@ -419,6 +436,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo enddo + end if + + if ( do_ugwp_v0.or.do_ugwp_v0_orog_only ) then + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then ! Override nmtvr with nmtvr_temp = 14 for passing into gwdps_run if necessary @@ -466,7 +487,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! ! ugwp_v0 non-stationary GW drag ! - if (do_ugwp_v0) then + if (do_ugwp_v0.or.do_ugwp_v0_nst_only) then if (cdmbgwd(3) > 0.0) then @@ -574,7 +595,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif - end if ! do_ugwp_v0 + end if ! do_ugwp_v0.or.do_ugwp_v0_nst_only ! diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 675a68edd..f60bdc038 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -207,6 +207,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_gsl_drag_ls_bl] standard_name = do_gsl_drag_ls_bl long_name = flag to activate GSL drag suite - large-scale GWD and blocking @@ -277,6 +285,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_ugwp_v1] standard_name = do_ugwp_v1 long_name = flag to activate ver 1 CIRES UGWP @@ -1293,6 +1309,14 @@ type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = do_ugwp_v0_nst_only + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_gsl_drag_ls_bl] standard_name = do_gsl_drag_ls_bl long_name = flag to activate GSL drag suite - large-scale GWD and blocking From 8463f3ad8fa38cf0b944fcd8a48194b75f0e8222 Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Wed, 20 Jan 2021 13:42:28 -0500 Subject: [PATCH 52/67] new GFS_phys_time_vary.fv3.F90; and new ugwp_common instead physcons --- physics/GFS_phys_time_vary.fv3.F90 | 50 +- physics/GFS_phys_time_vary.fv3.meta | 95 ++- physics/cires_tauamf_data.F90 | 63 +- physics/cires_ugwpv1_initialize.F90 | 253 ++++--- physics/cires_ugwpv1_module.F90 | 74 +- physics/cires_ugwpv1_oro.F90 | 1017 +++++++++++---------------- physics/cires_ugwpv1_solv2.F90 | 64 +- physics/cires_ugwpv1_sporo.F90 | 56 +- physics/cires_ugwpv1_triggers.F90 | 82 +-- physics/ugwpv1_gsldrag.F90 | 274 +++++--- physics/ugwpv1_gsldrag.meta | 128 ++-- 11 files changed, 1004 insertions(+), 1152 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 8f0bc50d9..04f191fdf 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -28,6 +28,9 @@ module GFS_phys_time_vary use iccninterp, only : read_cidata, setindxci, ciinterpol use gcycle_mod, only : gcycle + + use cires_tauamf_data, only: cires_indx_ugwp, read_tau_amf, tau_amf_interp + use cires_tauamf_data, only: tau_limb, days_limb, ugwp_taulat #if 0 !--- variables needed for calculating 'sncovr' @@ -58,6 +61,7 @@ subroutine GFS_phys_time_vary_init ( jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & nthrds, errmsg, errflg) implicit none @@ -77,6 +81,10 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) + + logical, intent(in) :: do_ugwp_v1 + real(kind_phys), intent(inout) :: ddy_j1tau(:), ddy_j2tau(:) + integer, intent(inout) :: jindx1_tau(:), jindx2_tau(:) integer, intent(in) :: nthrds character(len=*), intent(out) :: errmsg @@ -100,6 +108,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & +!$OMP shared (do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau) & !$OMP private (ix,i,j) !$OMP sections @@ -176,7 +185,11 @@ subroutine GFS_phys_time_vary_init ( ! No consistency check needed for in/ccn data, all values are ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif - +!$OMP section +!> - Call tau_amf dats for ugwp_v1 + if (do_ugwp_v1) then + call read_tau_amf(me, master, errmsg, errflg) + endif !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") @@ -211,7 +224,12 @@ subroutine GFS_phys_time_vary_init ( jindx2_ci, ddy_ci, xlon_d, & iindx1_ci, iindx2_ci, ddx_ci) endif - +!$OMP section +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs + if (do_ugwp_v1) then + call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau) + endif !$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 @@ -273,7 +291,8 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, errmsg, errflg) + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -297,11 +316,19 @@ subroutine GFS_phys_time_vary_timestep_init ( real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 real(kind_phys), intent(inout) :: rann(:,:) + + logical, intent(in) :: do_ugwp_v1 + integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) + real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) + real(kind_phys), intent(inout) :: tau_amf(:) + ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) + logical, intent(in) :: use_ufo, nst_anl, frac_grid + real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & @@ -310,7 +337,7 @@ subroutine GFS_phys_time_vary_timestep_init ( facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & - snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -404,7 +431,13 @@ subroutine GFS_phys_time_vary_timestep_init ( iindx2_ci, ddx_ci, & levs, prsl, in_nm, ccn_nm) endif - + +!> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that resolve GW-activ + if (do_ugwp_v1) then + call tau_amf_interp(me, master, im, idate,fhour, & + jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf) + endif + !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN @@ -479,7 +512,12 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (allocated(ciplin) ) deallocate(ciplin) if (allocated(ccnin) ) deallocate(ccnin) if (allocated(ci_pres) ) deallocate(ci_pres) - + + ! Deallocate UGWP-input arrays + if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) + if (allocated (tau_limb)) deallocate (tau_limb) + if (allocated (days_limb)) deallocate(days_limb) + is_initialized = .false. end subroutine GFS_phys_time_vary_finalize diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 7ae6b4948..e20920686 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F + dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] @@ -315,6 +315,48 @@ type = integer intent = in optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[jindx1_tau] + standard_name = index_interp_weight1_taungw + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[jindx2_tau] + standard_name = index_interp_weight2_taungw + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[ddy_j1tau] + standard_name = interp_weight1_taungw + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = interp_weight2_taungw + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = inout + kind = kind_phys + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1335,6 +1377,57 @@ kind = kind_phys intent = inout optional = F +[do_ugwp_v1] + standard_name = do_ugwp_v1 + long_name = flag to activate ver 1 CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F +[jindx1_tau] + standard_name = index_interp_weight1_taungw + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[jindx2_tau] + standard_name = index_interp_weight2_taungw + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[ddy_j1tau] + standard_name = interp_weight1_taungw + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[ddy_j2tau] + standard_name = interp_weight2_taungw + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + intent = in + kind = kind_phys + optional = F +[tau_amf] + standard_name = ngw_abs_momentum_flux + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_tauamf_data.F90 b/physics/cires_tauamf_data.F90 index 5a0296d4c..e0d43e74e 100644 --- a/physics/cires_tauamf_data.F90 +++ b/physics/cires_tauamf_data.F90 @@ -2,7 +2,7 @@ module cires_tauamf_data use machine, only: kind_phys !........................................................................................... -! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run +! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run !........................................................................................... implicit none @@ -25,7 +25,6 @@ subroutine read_tau_amf(me, master, errmsg, errflg) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg -! Tabulated sources ! iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) @@ -76,8 +75,7 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j use machine, only: kind_phys implicit none -! -! + integer, intent(in) :: npts, me, master real(kind=kind_phys) , dimension(npts), intent(in) :: dlat @@ -86,23 +84,7 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j !locals - integer :: i,j, j1, j2 - - - -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - - - if (me == master) then - print * - print *, ' ugwp_tabulated files input ' -! print *, ' ugwp_taulat ', ugwp_taulat -! print *, ' days ', days_limb - print *, ' TAU-ugwp ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 - print * - endif + integer :: i,j, j1, j2 ! do j=1,npts j2_tau(j) = ntau_d1y @@ -119,33 +101,16 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j if (j1_tau(j) /= j2_tau(j) ) then w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & - / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) - + / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) else w2_j2tau(j) = 1.0 endif w1_j1tau(j) = 1.0 - w2_j2tau(j) - enddo - return - - if (me == master ) then - -223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) - print *, 'ugwp-v1 indx_ugwp ', size(dlat), ' npts ', npts - do j=1,npts - j1 = j1_tau(j) - j2 = j2_tau(j) - write(6,223) j, ugwp_taulat(j1), dlat(j), ugwp_taulat(j2), w2_j2tau(j), w1_j1tau(j) - enddo - print * - - endif end subroutine cires_indx_ugwp - subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) - + subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) use machine, only: kind_phys implicit none @@ -165,7 +130,6 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd ! ! define day of year ddd ..... from the old-fashioned "GFS-style" -! having idate[4] ??? ! call gfs_idate_calendar(idate, fhour, ddd, fddd) @@ -196,12 +160,7 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) tau_ddd(i) = tx1*w1 + w2*tx2 enddo - -! if(me == master) then -! print *, ' tau_amf_interp : ', fddd, ddd , ' DOY ' -! print *, ' tau_amf_maxmin : ' , maxval(tau_ddd)*1.e3, minval(tau_ddd)*1.e3 -! endif - + end subroutine tau_amf_interp subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) @@ -235,22 +194,20 @@ subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) idat(5) = idate(1) rinc(1:5) = 0. rinc(2) = fhour -! get jdat +! call w3kind(w3kindreal,w3kindint) if(w3kindreal==4) then rinc4 = rinc call w3movdat(rinc4, idat,jdat) else call w3movdat(rinc, idat,jdat) - endif - -!! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) + endif +! jdate(8)- date and time (yr, mo, day, [tz], hr, min, sec) jdow = 0 jdoy = 0 jday = 0 call w3doxdat(jdat,jdow, ddd, jday) - fddd = float(ddd) + jdat(5) / 24. - + fddd = float(ddd) + jdat(5) / 24. end subroutine gfs_idate_calendar end module cires_tauamf_data diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/cires_ugwpv1_initialize.F90 index 1050da194..ad39def17 100644 --- a/physics/cires_ugwpv1_initialize.F90 +++ b/physics/cires_ugwpv1_initialize.F90 @@ -13,41 +13,83 @@ module ugwp_common ! use machine, only : kind_phys -! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & -! rv => con_rv, cpd => con_cp, fv => con_fvirt,& -! arad => con_rerth + implicit none - - real(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. - real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 - real(kind=kind_phys), parameter :: grav2 = grav + grav - real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav + + real(kind=kind_phys) :: pi, pi2, pih, rad_to_deg, deg_to_rad + real(kind=kind_phys) :: arad, p0s + real(kind=kind_phys) :: grav, grav2, rgrav, rgrav2 + real(kind=kind_phys) :: cpd, rd, rv, fv + real(kind=kind_phys) :: rdi, rcpd, rcpd2 + + real(kind=kind_phys) :: gor, gr2, grcp, gocp, rcpdl, grav2cpd + real(kind=kind_phys) :: bnv2min, bnv2max + real(kind=kind_phys) :: dw2min, velmin, minvel + real(kind=kind_phys) :: omega1, omega2, omega3 + real(kind=kind_phys) :: hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm + real(kind=kind_phys) :: mkzmin, mkz2min, mkzmax, mkz2max, cdmin + real(kind=kind_phys) :: rcpdt - real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 - real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd - real(kind=kind_phys), parameter :: gor = grav/rd - real(kind=kind_phys), parameter :: gr2 = grav*gor - real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp - real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - - real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi - real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 - - real(kind=kind_phys), parameter :: arad = 6370.e3 +! real(kind=kind_phys), parameter :: grav2 = grav + grav +! real(kind=kind_phys), parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav +! real(kind=kind_phys), parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd +! real(kind=kind_phys), parameter :: gor = grav/rd, rcpdt = 1./(cp*dtp) + +! real(kind=kind_phys), parameter :: gr2 = grav*gor +! real(kind=kind_phys), parameter :: grcp = grav*rcpd, gocp = grcp +! real(kind=kind_phys), parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g +! real(kind=kind_phys), parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp +! real(kind=kind_phys), parameter :: pi2 = 2.*pi, pih = .5*pi +! real(kind=kind_phys), parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 ! - real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) - real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) - - real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 - real(kind=kind_phys), parameter :: omega1 = pi2/86400. - real(kind=kind_phys), parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 - real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp - real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin - real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax - real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax +! real(kind=kind_phys), parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) +! real(kind=kind_phys), parameter :: bnv2max = (pi2/30.)*(pi2/30.) +! real(kind=kind_phys), parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 +! real(kind=kind_phys), parameter :: omega1 = pi2/86400., omega2 = 2.*omega1, omega3 = 3.*omega1 +! +! real(kind=kind_phys), parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp +! real(kind=kind_phys), parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin +! real(kind=kind_phys), parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax +! real(kind=kind_phys), parameter :: cdmin = 2.e-2/mkzmax +! real(kind=kind_phys), parameter :: pi = 4.*atan(1.0), +! real(kind=kind_phys), parameter :: grav =9.81, cpd = 1004. +! real(kind=kind_phys), parameter :: rd = 287.0 , rv =461.5 +! real(kind=kind_phys), parameter :: fv = rv/rd - 1.0 +! real(kind=kind_phys), parameter :: arad = 6370.e3 end module ugwp_common + + subroutine init_nazdir(naz, xaz, yaz) + + use machine, only : kind_phys + use ugwp_common, only : pi2 + + implicit none + + integer :: naz + real(kind=kind_phys), dimension(naz) :: xaz, yaz + integer :: idir + real(kind=kind_phys) :: phic, drad + + drad = pi2/float(naz) + if (naz.ne.4) then + do idir =1, naz + Phic = drad*(float(idir)-1.0) + xaz(idir) = cos(Phic) + yaz(idir) = sin(Phic) + enddo + else +! if (naz.eq.4) then + xaz(1) = 1.0 !E + yaz(1) = 0.0 + xaz(2) = 0.0 + yaz(2) = 1.0 !N + xaz(3) =-1.0 !W + yaz(3) = 0.0 + xaz(4) = 0.0 + yaz(4) =-1.0 !S + endif + end subroutine init_nazdir ! ! !=================================================== @@ -55,21 +97,14 @@ end module ugwp_common !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - me, master) -! -! ccpp-damn con_pi !!! -! -!non-ccpp subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) -!non-ccpp use ugwp_common, only : pih - + subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! use machine , only : kind_phys - + use ugwp_common, only : pih, pi implicit none integer , intent(in) :: me, master integer , intent(in) :: levs - real(kind=kind_phys), intent(in) :: con_pi real(kind=kind_phys), intent(in) :: zkm(levs), pmb(levs) ! in km-Pa real(kind=kind_phys), intent(out), dimension(levs+1) :: kvg, ktg, krad, kion ! @@ -94,15 +129,11 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & real(kind=kind_phys), parameter :: zdrag = 100. real(kind=kind_phys), parameter :: zgrow = 50. ! - real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag + real(kind=kind_phys) :: vumol, mumol, keddy, ion_drag real(kind=kind_phys) :: rf_fv3, rtau_fv3, ptop, pih_dlog ! real(kind=kind_phys) :: ae1 ,ae2 ! -! ccpp con_pi -! - real(kind=kind_phys) :: pih - pih = 0.5*con_pi ptop = pmb(levs) rtau_fv3 = 1./86400./tau_alp @@ -141,14 +172,14 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & kvg(k) = kvg(k-1) ktg(k) = ktg(k-1) - if (me == master) then - write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ... init_global_gwdis' - do k=1, levs, 1 - write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) - enddo - endif -! - 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) +! if (me == master) then +! write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ... init_global_gwdis' +! do k=1, levs, 1 +! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) +! enddo +! endif +! +! 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) end subroutine init_global_gwdis ! @@ -161,7 +192,7 @@ end subroutine init_global_gwdis ! !========================================================================= module ugwp_oro_init - use machine , only : kind_phys + use machine , only : kind_phys use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi use ugwp_common, only : mkzmin, mkz2min implicit none @@ -182,6 +213,7 @@ module ugwp_oro_init character(len=8) :: strver = 'gfs_2018' character(len=8) :: strbase = 'gfs_2018' + real(kind=kind_phys), parameter :: rimin=-10., ric=0.25 real(kind=kind_phys), parameter :: frmax=10., frc =1.0, frmin =0.01 @@ -190,9 +222,10 @@ module ugwp_oro_init real(kind=kind_phys), parameter :: efmin=0.5, efmax=10.0 real(kind=kind_phys), parameter :: rlolev=50000.0 - integer,parameter :: mdir = 8 - real(kind=kind_phys), parameter :: fdir=.5*mdir/pi - + integer, parameter :: mdir = 8 + real(kind=kind_phys), parameter :: fdir=mdir/(8.*atan(1.0)) + real(kind=kind_phys), parameter :: zpgeo=2.*atan(1.0) + integer nwdir(mdir) data nwdir/6,7,5,8,2,3,1,4/ save nwdir @@ -202,14 +235,14 @@ module ugwp_oro_init real(kind=kind_phys), parameter :: fcrit_gfs = 0.7, fcrit_v1 = 0.7 real(kind=kind_phys), parameter :: fcrit_mtb = 0.7 - real(kind=kind_phys), parameter :: zbr_pi = (1.0/2.0)*pi - real(kind=kind_phys), parameter :: zbr_ifs = 0.5*pi + real(kind=kind_phys), parameter :: zbr_pi = zpgeo + real(kind=kind_phys), parameter :: zbr_ifs = zpgeo ! real(kind=kind_phys), parameter :: kxoro=6.28e-3/200. ! real(kind=kind_phys), parameter :: coro = 0.0 - integer,parameter :: nridge=2 + integer,parameter :: nridge=2 real(kind=kind_phys), parameter :: sigma_std=1./100., gamm_std=1.0 real(kind=kind_phys) :: cdmb ! scale factors for mtb @@ -291,8 +324,10 @@ end module ugwp_oro_init ! !========================================================================= module ugwp_conv_init + use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + + implicit none real(kind=kind_phys) :: eff_con ! scale factors for conv GWs integer :: nwcon ! number of waves @@ -313,17 +348,9 @@ module ugwp_conv_init real(kind=kind_phys), allocatable :: xaz_conv(:), yaz_conv(:) contains ! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - con_pi, arad, lonr, kxw) -! -! non-ccpp with use ugwp_common -! -! subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & -! lonr, kxw) + subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) ! -! use ugwp_common, only : pi2, arad - - + use ugwp_common, only : pi2, arad implicit none @@ -333,7 +360,6 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & ! ! ccpp ! - real(kind=kind_phys) :: con_pi, arad real(kind=kind_phys) :: kxw, effac real(kind=kind_phys) :: work1 = 0.5 @@ -345,7 +371,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & nstcon = nstoch eff_con = effac - con_dlength = 2.0*con_pi*arad/float(lonr) + con_dlength = pi2*arad/float(lonr) ! ! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" ! @@ -370,7 +396,7 @@ subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & snorm = sum(spf_conv) spf_conv = spf_conv/snorm*1.5 - call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) + call init_nazdir(nazdir, xaz_conv, yaz_conv) end subroutine init_conv_gws @@ -383,7 +409,8 @@ end module ugwp_conv_init module ugwp_fjet_init use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + + implicit none real(kind=kind_phys) :: eff_fj ! scale factors for conv GWs @@ -401,18 +428,14 @@ module ugwp_fjet_init real(kind=kind_phys), allocatable :: xaz_fjet(:), yaz_fjet(:) contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) -! non-ccpp -! -! subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) -! use ugwp_common, only : pi2, arad + subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac,lonr, kxw) + + use ugwp_common, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch integer :: lonr - real(kind=kind_phys) :: con_pi real(kind=kind_phys) :: kxw, effac , chk integer :: k @@ -433,7 +456,7 @@ subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & ch_fjet(k) = chk spf_fjet(k) = 1.0 enddo - call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) + call init_nazdir(nazdir, xaz_fjet, yaz_fjet) end subroutine init_fjet_gws @@ -444,8 +467,8 @@ end module ugwp_fjet_init ! module ugwp_okw_init !========================================================================= - use machine , only : kind_phys - use cires_ugwpv1_triggers, only :init_nazdir + use machine , only : kind_phys + implicit none real(kind=kind_phys) :: eff_okw ! scale factors for conv GWs @@ -463,17 +486,15 @@ module ugwp_okw_init contains ! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) + -! subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) -! use ugwp_common, only : pi2, arad + subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) + use ugwp_common, only : pi2, arad implicit none integer :: nwaves, nazdir, nstoch integer :: lonr - real(kind=kind_phys) :: con_pi real(kind=kind_phys) :: kxw, effac , chk integer :: k @@ -493,10 +514,8 @@ subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & ch_okwp(k) = chk spf_okwp(k) = 1. enddo - - call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) -! non-ccpp -! call init_nazdir(nazdir, xaz_okwp, yaz_okwp) + + call init_nazdir(nazdir, xaz_okwp, yaz_okwp) ! end subroutine init_okw_gws @@ -557,10 +576,11 @@ end module ugwp_lsatdis_init ! ! module ugwp_wmsdis_init + use machine , only : kind_phys use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 use ugwp_common, only : bnv2max, bnv2min, minvel - use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin + use ugwp_common, only : mkzmin, mkz2min, mkzmax, mkz2max, ucrit => cdmin implicit none @@ -569,7 +589,7 @@ module ugwp_wmsdis_init real(kind=kind_phys), parameter :: gptwo=2.0 - real(kind=kind_phys) , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix + real(kind=kind_phys) , parameter :: bnfix = 6.28/300., bnfix2= bnfix * bnfix real(kind=kind_phys) , parameter :: bnfix4 = bnfix2 * bnfix2 real(kind=kind_phys) , parameter :: bnfix3 = bnfix2 * bnfix ! @@ -577,7 +597,6 @@ module ugwp_wmsdis_init ! integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum - real(kind=kind_phys) , parameter :: ucrit=cdmin real(kind=kind_phys) , parameter :: zcimin = 2.5 real(kind=kind_phys) , parameter :: zcimax = 125.0 @@ -684,13 +703,13 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, allocate ( zcosang(nazd), zsinang(nazd) ) allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) - if (me == master) then - print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' +! if (me == master) then +! print *, 'ugwp_v1/v0: init_gw_wmsdis_control ' ! - print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch - print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. - print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 - endif +! print *, 'ugwp_v1/v0: WMS_DIS launch layer ', ilaunch +! print *, 'ugwp_v1/v0: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. +! print *, 'ugwp_v1/v0: WMS_DIS lhmet in km ' , lhmet*1.e-3 +! endif zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. @@ -763,13 +782,16 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, enddo zdx = (zci(nwav)-zci(1))/ real(nwav-1) - do inc=1, nwav + do inc=1, nwav zdci(inc) = zdx - enddo + enddo - cstar = bnfix/zms - rcstar = 1./cstar - + cstar = bnfix/zms + rcstar = 1./cstar + ENDIF ! if (version == 1) then + + RETURN +!=================== Diag prints after return ==================== if (me == master) then print * print *, 'ugwp_v0: zcimin=' , zcimin @@ -788,15 +810,16 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, print * nslope3=nslope+3.0 - do inc=1, nwav - zcin =zci(inc)*rcstar - fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) - fpc_dc = fpc * zdci(inc) - write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) - enddo + do inc=1, nwav + zcin =zci(inc)*rcstar + fpc = rcstar*(zcin*zcin)/(1.+ zcin**nslope3) + fpc_dc = fpc * zdci(inc) + write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) + enddo endif - ENDIF ! if (version == 1) then + + 111 format( 'wms-zci', i4, 7 (3x, F8.3)) end subroutine initsolv_wmsdis diff --git a/physics/cires_ugwpv1_module.F90 b/physics/cires_ugwpv1_module.F90 index eb740c7eb..13b7752a5 100644 --- a/physics/cires_ugwpv1_module.F90 +++ b/physics/cires_ugwpv1_module.F90 @@ -10,7 +10,7 @@ module cires_ugwpv1_module ! ! use machine, only : kind_phys - use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 + use ugwp_common, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, rhp4, khp, hpskm use ugwp_wmsdis_init, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar use ugwp_wmsdis_init, only : tau_min, tamp_mpa @@ -22,6 +22,7 @@ module cires_ugwpv1_module logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver integer, parameter :: idebug_gwrms=0 ! control for diag computaions pw wind-temp GW-rms and MF fluxs logical, parameter :: do_adjoro = .false. + real(kind=kind_phys), parameter :: max_kdis = 450. ! 400 m2/s real(kind=kind_phys), parameter :: max_axyz = 450.e-5 ! 400 m/s/day real(kind=kind_phys), parameter :: max_eps = max_kdis*4.e-4 ! max_kdis*BN2 @@ -39,15 +40,8 @@ module cires_ugwpv1_module real(kind=kind_phys), parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw real(kind=kind_phys), parameter :: iPr_turb =1./3., iPr_mol =1.95 - - real(kind=kind_phys), parameter :: hps = hpscale - real(kind=kind_phys), parameter :: hpskm = hps/1000. -! - real(kind=kind_phys), parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 - real(kind=kind_phys), parameter :: khp = 0.287*rhp1 ! R/Cp/Hp - real(kind=kind_phys), parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model - real(kind=kind_phys), parameter :: linsat = 1.00 + real(kind=kind_phys), parameter :: linsat = 1.00 real(kind=kind_phys), parameter :: linsat2 = linsat*linsat real(kind=kind_phys), parameter :: ricrit = 0.25 @@ -75,41 +69,26 @@ module cires_ugwpv1_module real(kind=kind_phys) :: knob_ugwp_taumin = 0.25e-3 real(kind=kind_phys) :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) real(kind=kind_phys) :: knob_ugwp_lhmet = 200.e3 ! 200 km + logical :: knob_ugwp_tlimb = .true. character(len=8) :: knob_ugwp_orosolv='pss-1986' - real(kind=kind_phys) :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes -! -! tune-ups for qbo -! -! real(kind=kind_phys) :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs -! real(kind=kind_phys) :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians -! real(kind=kind_phys) :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing -! real(kind=kind_phys) :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO -! real(kind=kind_phys) :: knob_ugwp_qbotau = 10. ! relaxation time scale in days -! real(kind=kind_phys) :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing -! real(kind=kind_phys) :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing -! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! -! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' -! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' -! integer, parameter :: ny_tab=73, nt_tab=14 -! real(kind=kind_phys), parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. -! integer :: nqbo_d1y, nqbo_d2z, nqbo_d3t - + real(kind=kind_phys) :: kxw = 6.28/200.e3 ! single horizontal wavenumber of ugwp schemes +! integer :: ugwp_azdir integer :: ugwp_stoch integer :: ugwp_src integer :: ugwp_nws + real(kind=kind_phys) :: ugwp_effac - ! integer :: launch_level = 55 ! namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & - knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & + knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & knob_ugwp_tlimb, knob_ugwp_orosolv ! @@ -119,17 +98,11 @@ module cires_ugwpv1_module real(kind=kind_phys), allocatable :: kvg(:), ktg(:), krad(:), kion(:) real(kind=kind_phys), allocatable :: zkm(:), pmb(:) real(kind=kind_phys), allocatable :: rfdis(:), rfdist(:) - integer :: levs_rf +! +! RF-not active now +! + integer :: levs_rf real(kind=kind_phys) :: pa_rf, tau_rf -!........................................................................................... -! tabulated GW-sources: GRACILE/Ern et al., 2018 and/or Resolved GWs from C384-Annual run -!........................................................................................... - -! integer :: ntau_d1y, ntau_d2t -! real(kind=kind_phys), allocatable :: ugwp_taulat(:) -! real(kind=kind_phys), allocatable :: tau_limb(:,:), days_limb(:) -! logical :: flag_alloctau = .false. -! character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc' ! ! simple modulation of tau_ngw by the total rain/precip strength ! @@ -300,11 +273,10 @@ subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & print *, 'cires_ugwpv1 klev_ngw =', launch_level, nint(pmb(launch_level)) endif ! -! Part-1 :init_global_gwdis again "damn"-con_pi -! call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) +! Part-1 :init_global_gwdis again "damn"-con_p ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - me, master) + call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion, me, master) + ! ! Part-2 :init_SOURCES_gws ! @@ -321,30 +293,30 @@ subroutine cires_ugwpv1_init (me, master, nlunit, logunit, jdat_gfs, con_pi, & IF (do_physb_gwsrcs) THEN - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' +! if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_modv1 ' if (knob_ugwp_wvspec(4) > 0) then ! okw call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & knob_ugwp_stoch(4), knob_ugwp_effac(4), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' + lonr, kxw ) +! if (me == master) print *, ' init_okw_gws ' endif if (knob_ugwp_wvspec(3) > 0) then ! fronts call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & knob_ugwp_stoch(3), knob_ugwp_effac(3), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' + lonr, kxw ) +! if (me == master) print *, ' init_fjet_gws ' endif if (knob_ugwp_wvspec(2) > 0) then ! conv : con_pi, con_rerth, call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), & - con_pi, con_rerth, lonr, kxw ) - if (me == master) & - print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) + lonr, kxw ) +! if (me == master) & +! print *, ' init_convective GWs ', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) endif diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 6913b4c0e..46191f404 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -3,7 +3,6 @@ module cires_ugwpv1_oro contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & - grav, con_omega, rd, cpd, rv, pi, arad, fv, & xlatd, sinlat, coslat, sparea, & cdmbgwd, hprime, oc, oa4, clx4, theta, sigmad, & gammad, elvmaxd, sgh30, kpbl, & @@ -13,18 +12,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_ofdcol, dv_ofdcol, errmsg,errflg ) - -! call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & -! con_g, con_omega, con_rd, con_cp, con_rv,con_pi, con_rerth, con_fvirt, & -! xlat_d, sinlat, coslat, area, & -! cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & -! sigma, gamma, elvmax, varss, kpbl, & -! ugrs, vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & -! Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & -! zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & -! dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & -! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & -! du_ofdcol, dv_ofdcol, errmsg,errflg ) !--------------------------------------------------------------------------- ! ugwp_v1: orogw_v1 following recent updates of Lott & Miller 1997 @@ -42,19 +29,21 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! cdmbgwd(1) = 1 for all resolutions, number of hills control SA-effects ! cdmbgwd(2) = 1 ...............number of hills control SA-effects ! -! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) +! (c) cleff = pi2/(nk*dx) lheff = nk*dx (nk = 6,4,2, 1) ! alternative lheff = min( dogw=hprime/sigma*gamma, dx) ! we still not use the "broad spectral solver" ! -! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW +! (d) hefff = (nsig * hprime -znlk)/nsig, orchestrating MB and OGW ! -! (e) for linsat-solver "eddy" damping Ked = Ked * Nhills, scale-aware -! amplification of the momentum deposition for low-res simulations +! (e) for linsat-solver the total "eddy" damping Ked = Ked * Nhills, +! scale-aware amplification of the momentum deposition for low-res runs !---------------------------------------- use machine , only : kind_phys - use ugwp_common, only : dw2min, velmin - + use ugwp_common, only : dw2min, velmin, grav, omega1, rd, cpd, rv, pi, arad, fv + use ugwp_common, only : rcpdt, grav2, rgrav, rcpd, rcpd2 + use ugwp_common, only : rad_to_deg, deg_to_rad, pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min + use ugwp_oro_init, only : rimin, ric, efmin, efmax, & hpmax, hpmin, sigfaci => sigfac, & dpmin, minwnd, hminmt, hncrit, & @@ -65,8 +54,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & n_tofd, ze_tofd, ztop_tofd use cires_ugwpv1_module, only : kxw, max_kdis, max_axyz - -! use cires_ugwpv1_sporo, only : oro_spectral_solver !---------------------------------------- implicit none @@ -103,9 +90,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & clx4(im,4), theta(im), & sigmad(im), gammad(im), elvmaxd(im) - - real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, pi, arad, fv - +! real(kind=kind_phys), intent(in) :: sgh30(im) real(kind=kind_phys), intent(in), dimension(im,km) :: & @@ -134,17 +119,6 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! -!--------------------------------------------------------------------- -! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 -! 4.*gamma*b_ell*b_ell >= shilmin -! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min -! gamma_min = 1/4*shilmin/sso_min/sso_min -!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 -! 192: cdmbgwd = 0.5, 2.5 -! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km -! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin -!--------------------------------------------------------------------- ! ! locals vars for SSO ! @@ -208,14 +182,14 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & real(kind=kind_phys) :: scork, rscor, hd, fro, sira real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk - real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + real(kind=kind_phys) :: windik, wdir real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 real(kind=kind_phys) :: belps, aelps, nhills, selps - real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad - real(kind=kind_phys) :: pi2, pi2h, rdi, gor, grcp, gocp, gr2, bnv2min +! real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad +! real(kind=kind_phys) :: pi2, pih, rdi, gor, grcp, gocp, gr2, bnv2min real(kind=kind_phys) :: cleff_max ! resolution-aware max-wn real(kind=kind_phys) :: nonh_fact ! non-hydroststic factor 1.-(kx/kz_hh)**2 @@ -253,8 +227,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & !---- for lm and gwd calculation points ! ccpp-gwdps.f PARAMETER (hpmax=2400.0, hpmin=1.0) parameter (elvmax > hminmt=50.) - npt = 0 - + npt = 0 do i = 1,im if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then npt = npt + 1 @@ -262,38 +235,18 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & endif enddo - if (npt == 0) then - + if (npt == 0) then ! print *, 'orogw_v1 npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin - +! print *, 'orogw_v1 npt = 0 hprime ', maxval(hprime), hpmin return ! no ogw/mbl calculation done endif -!=========================== -! scalars from phys-contants added by "CCPP-team" -! by rejecting to use "ugwp_common" -!=========================== - rcpdt = 1.0 / (cpd*dtp) - grav2 = grav + grav -! - rgrav = 1.0/grav - rcpd = 1.0/cpd - rcpd2 = 0.5/cpd - rad_to_deg=180.0/pi - deg_to_rad=pi/180.0 - pi2 = 2.*pi - pi2h = 0.5*pi - rdi = 1.0/rd - gor = grav/rd - grcp = grav*rcpd - gocp = grcp - gr2 = grav*gor - bnv2min = (pi2/1800.)*(pi2/1800.) ! tau_BV_max = 30 min ! -!=========================== -! Start -! -! initialize gamma and sigma -! + + +!================================= +! Start if npt >= 1 +! initialize gamma and sigma for +! performing the QC of SSO inputs +!================================= gamma(:) = gammad(:) sigma(:) = sigmad(:) ! @@ -314,16 +267,14 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! sigma-degined as tan(angle) = h/2: L/2= h/L sigmin = hpmin/hdxres ! min-slope Hmin= 2*hpmin, dxres=Lmax - - - if ( kdt == -1 .and. me == master) then - print *, ' orogw_v1 scale2 ', cdmbgwd(2) - print *, ' orogw_v1 imx ', imx - print *, ' orogw_v1 gam_min ', gammin - print *, ' orogw_v1 sso_min ', sso_min - print *, ' orogw_v1 gam_min ', gammin - print *, ' orogw_v1 npt number of GRID-cells with hills ', npt - endif +! if ( kdt == 1 .and. me == master) then +! print *, ' orogw_v1 scale2 ', cdmbgwd(2) +! print *, ' orogw_v1 imx ', imx +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 sso_min ', sso_min +! print *, ' orogw_v1 gam_min ', gammin +! print *, ' orogw_v1 npt number of GRID-cells with hills ', npt +! endif !============================================================ ! Purpose to adjust oro-specification on the fly @@ -332,7 +283,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! width_mount_a = hprime/sigma < dxres cannot access dxres ! width_mount_b = width_mount_a * gamma ! -! Sellipse= pi a*b = (width_mount_a)^2 *gamma <= Sarea +! Sellipse= pi * a*b = (width_mount_a)^2 *gamma <= Sarea ! Limiters on "elongated" hills gamma= a/b < gam_min ! Limiters on "longest" hills (b, a) <= sqrt(area) ! @@ -362,7 +313,7 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & if (do_adjoro ) then ! -! more adjustments "lengths", gamma and sigma, valid assuminng H=2*hprime H/2 = hprime +! more adjustments "lengths", gamma and sigma, assuminng H_hill=2*hprime ! if (hprime(i) > hdxres*sigres) sigres= hprime(i)/dxres aelps = min( hprime(i)/sigres, hdxres) @@ -388,47 +339,45 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & gamma(i) = min(aelps/belps, 1.0) endif !aelps < sso_min - endif ! ============== (do_adjoro ) + endif ! if (do_adjoro ) - selps = belps*belps*gamma(i)*pi ! area of the elliptical hill - + selps = belps*belps*gamma(i)*pi ! area of the elliptical hill nhills = min(nhilmax, sparea(i)/selps) arhills(j) = max(nhills, 1.0) ! if (kdt==1 ) write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, belps*1.e-3, sigma(i),gamma(i) - +! 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) enddo - 333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) + !======================================================================= ! mtb-blocking : LM-1997; Zadra et al. 2004 ;metoffice dec 2010 H Wells !======================================================================= - do i=1,npt - khtop(i) = 2 - idxzb(i) = 0 - enddo + do i=1,npt + khtop(i) = 2 + idxzb(i) = 0 + izlow(i) = 1 + enddo - do k=1,km - do i=1,im + do k=1,km + do i=1,im db(i,k) = 0.0 ang(i,k) = 0.0 uds(i,k) = 0.0 - enddo + enddo enddo kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 - lcap = km ; lcapp1 = lcap + 1 - + lcap = km ; lcapp1 = lcap + 1 cdmb4 = 0.25*cdmb do i = 1, npt j = ipt(i) + elvmax(j) = min( sigfac * hprime(j), hncrit) ! -!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) Max-level of SSO-HILL -! - elvmax(j) = min ( sigfac * hprime(j), hncrit) - izlow(i) = 1 ! surface-level +!gfsv15/16: ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit=8000.) +! SSO-effects from the surface to "ELVMAX" =4*hprime + ELVMAX enddo @@ -444,193 +393,148 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & do k = 1, kmm1 - do i = 1, npt - j = ipt(i) - - ztoph = sigfac * hprime(j) - zlowh = sigfacs* hprime(j) - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) + do i = 1, npt + j = ipt(i) + ztoph = sigfac * hprime(j) + zlowh = sigfacs* hprime(j) + zmetp = zmet(j,k+1) + zmetk = zmet(j,k) ! ! GFSv15/16: izlow=1 ! elvmax(j)=elvmaxd(J) + sig*hp: if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) khtop(i) = max(khtop(i), k+1 ) ! - if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(i), k+1 ) - if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) - - enddo + if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) khtop(i) = max(khtop(i), k+1 ) + if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) + enddo enddo ! do k = 1,km - do i =1,npt - j = ipt(i) - vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) - vtk(i,k) = vtj(i,k) / prslk(j,k) - ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels - taup(i,k) = 0.0 - enddo + do i =1,npt + j = ipt(i) + vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) + vtk(i,k) = vtj(i,k) / prslk(j,k) + ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid + taup(i,k) = 0.0 + enddo enddo ! ! perform ri_n or ri_mf computation for both OGW and OBL -! +!23456 do k = 1,kmm1 - do i =1,npt - j = ipt(i) - rdz = 1. / (zmet(j,k+1) - zmet(j,k)) - tem1 = u1(j,k) - u1(j,k+1) - tem2 = v1(j,k) - v1(j,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) + do i =1,npt + j = ipt(i) + rdz = 1. / (zmet(j,k+1) - zmet(j,k)) + tem1 = u1(j,k) - u1(j,k+1) + tem2 = v1(j,k) - v1(j,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) - bnv2(i,k+1) = max( bvf2, bnv2min ) - ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 -! -! place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme + bnv2(i,k+1) = max( bvf2, bnv2min ) + ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 +! having ri_n +! we may place here computation for "ktur" and ogw-dissipation for the spectral ORO-scheme ! - enddo + enddo enddo k = 1 +!23456 do i = 1, npt bnv2(i,k) = bnv2(i,k+1) enddo ! ! level khtop => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) -! +!23456 do i = 1, npt - j = ipt(i) - k_zlow = izlow(i) - if (k_zlow == khtop(i)) k_zlow = 1 - delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) -! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - pe (i) = 0.0 - ek (i) = 0.0 - bnv2bar(i) = 0.0 + j = ipt(i) + k_zlow = izlow(i) + if (k_zlow == khtop(i)) k_zlow = 1 + delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,khtop(i))) +! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,khtop(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + pe (i) = 0.0 + ek (i) = 0.0 + bnv2bar(i) = 0.0 ! ! computation of the mean flow char zlow < z < ztop =sigfac*hprime -! - do k = k_zlow, khtop(i)-1 - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) - vbar(i) = vbar(i) + rdelks * v1(j,k) - roll(i) = roll(i) + rdelks * ro(i,k) - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - enddo +!23456 + do k = k_zlow, khtop(i)-1 + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + enddo enddo -! +!23456 do i = 1, npt - j = ipt(i) + j = ipt(i) ! ! integrate from ztoph = sigfac*hprime down to zblk if exists ! find ph_blk, dz_blk as introduced in LM-97 and ifs -! - ph_blk =0. - do k = khtop(i), 1, -1 - - phiang = atan2(v1(j,k),u1(j,k)) - phiang = theta(j)*rad_to_deg - phiang - - if ( phiang > pi2h ) phiang = phiang - pi - if ( phiang < -pi2h ) phiang = phiang + pi - ang(i,k) = phiang - uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) -! - if (idxzb(i) == 0 ) then - dz_blk = zmeti(j,k+1) - zmeti(j,k) - pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk - - up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) - ek(i) = 0.5 * up(i) * up(i) - - ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) +!23456 + ph_blk =0. + do k = khtop(i), 1, -1 + phiang = atan2(v1(j,k),u1(j,k)) + phiang = theta(j)*rad_to_deg - phiang + if ( phiang > pih ) phiang = phiang - pi + if ( phiang < -pih ) phiang = phiang + pi + ang(i,k) = phiang + uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) +!23456 + if (idxzb(i) == 0 ) then + dz_blk = zmeti(j,k+1) - zmeti(j,k) + pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk + up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) + ek(i) = 0.5 * up(i) * up(i) + ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) ! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs ! if ( pe(i) >= ek(i) ) then -! --- LM97 - if ( ph_blk >= fcrit_v1 ) then - idxzb(i) = k - zobl (j) = zmet(j, k) - rdxzb(j) = real(k, kind=kind_phys) - endif - - endif - enddo -! -! fcrit_v1/fr_flow -! - goto 788 -! -! alternative expression for blocking: -! zobl = max(heff*(1. -fcrit_v1/fr_Flow), 0) -! -! - - bnv = sqrt( bnv2bar(i) ) - heff = 2.*min(hprime(j),hpmax) - zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) - ulow(i) = sqrt(max(zw2,dw2min)) - fr = heff*bnv/ulow(i) - zw1 = max(heff*(1. -fcrit_v1/fr), 0.0) - zw2 = zmet(j,2) - - if (fr > fcrit_v1 .and. zw1 > zw2 ) then - do k=2, kmm1 - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) - if (zw1 <= zmetp .and. zw1 >= zmetk) exit - enddo - idxzb(i) = k - zobl (j) = zmet(j, k) - endif -788 continue +! --- LM97/IFS + if(ph_blk >= fcrit_v1 ) then + idxzb(i) = k + zobl (j) = zmet(j, k) + rdxzb(j) = real(k, kind=kind_phys) + endif +!23456 + endif + enddo ! ! --- the drag for the blocked flow ! - if ( idxzb(i) > 0 ) then + if ( idxzb(i) > 0 ) then ! ! (4.16)-ifs description ! gam2 = gamma(j)*gamma(j) bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 - cgam = 0.48*gamma(j) + 0.30*gam2 - - do k = idxzb(i)-1, 1, -1 -! -! empirical height dep-nt "blocking" length from LM-1997 + cgam = 0.48*gamma(j) + 0.30*gam2 + do k = idxzb(i)-1, 1, -1 +!23456 +! empirical height dep-nt "blocking" length from LM-1997/IFS ! - zlen = sqrt( (zobl(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) -! -! - tem = cos(ang(i,k)) - cosang2 = tem * tem - sinang2 = 1.0 - cosang2 -! -! cos =1 sin =0 => 1/r= gam zr = 2.-gam -! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam -! - rdem = cosang2 + gam2 * sinang2 - rnom = cosang2*gam2 + sinang2 + zlen = sqrt( (zobl(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) + tem = cos(ang(i,k)) + cosang2 = tem * tem + sinang2 = 1.0 - cosang2 + rdem = cosang2 + gam2 * sinang2 + rnom = cosang2*gam2 + sinang2 ! ! metoffice dec 2010 ! correction of H. Wells & A. Zadra for the -! aspect ratio of the hill seen by mean flow -! (1/r , r-inverse below: 2-r) - - rdem = max(rdem, 1.e-6) - r = sqrt(rnom/rdem) - zr = max( 2. - r, 0. ) - sigres = max(sigmin, sigma(j)) - - mtbridge = zr * sigres*zlen / hprime(j) -! (4.15)-ifs -! dbtmp = cdmb4 * mtbridge * & -! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) -! (4.16)-ifs - dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) +! aspect ratio of the elliptical hill seen by mean flow +! + rdem = max(rdem, 1.e-6) + r = sqrt(rnom/rdem) + zr = max( 2. - r, 0. ) + sigres = max(sigmin, sigma(j)) + mtbridge = zr * sigres*zlen / hprime(j) +! dbtmp = cdmb4*mtbridge*max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) ! (4.15)-ifs + dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam * sinang2) ! (4.16)-ifs ! ! linear damping due to OBL [1/sec]=[U/L_block_orthogonal] ! more accurate along 2-axes of ellipse, here zr-factor is based on Phillips' analytics @@ -638,13 +542,13 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & db(i,k)= dbtmp * uds(i,k) ! if (db(i,k) > dbmax) print *, ' db > dbmax ', 1./db(i,k)/3600., uds(i,k) db(i,k)= min(db(i,k), dbmax) - enddo -! - endif + enddo +!23456 + endif enddo !............................. !............................. -! end mtn blocking section +! finish the mtn blocking !............................. !............................. ! @@ -657,78 +561,72 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & iwk(1:npt) = 2 ! ! in meto/UK-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! +! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations in taub_ogw +!23456 do k=3,kmpbl - do i=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem < dpmin) iwk(i) = k ! dpmin=50 mb from the surface - enddo + do i=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem < dpmin) iwk(i) = k ! dpmin=50 mb from the surface + enddo enddo -! -! iwk - adhoc criteria to select ghe ogw-launch level between -! level ~0.4-0.5 km from surface or/and HPBL-top -! -! in all UGWP-schemes: zogw > zobl -! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb -! the top hill can be inside PBL.... if kref = khtop +! +! in all cires-UGWP-schemes: zogw > zobl +! in ugwp-v1: we consider option for htop ~ (2-3)*hprime > zmtb +! the top of hill can be inside the PBL.... if kref = khtop ! kbps = 1 kmps = km k_mtb = 1 - +!23456 do i=1,npt - j = ipt(i) - k_mtb = max(1, idxzb(i)) + j = ipt(i) + k_mtb = max(1, idxzb(i)) ! WRF/GSL: kogw = max(kpbl, ktop=2*var) - kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime - kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime -! -! zogw > zobl -! - if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above blocking - kbps = max(kbps, kref(i)) - kmps = min(kmps, kref(i)) -! - delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - bnv2bar(i)= 0.0 + kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else...Zogw= sigfac*Hprime + kref(i) = max(kref(i), khtop(i) ) ! khtop => sigfac*hprime +!zogw > zobl + if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! OGW-layer above the blocking height + kbps = max(kbps, kref(i)) + kmps = min(kmps, kref(i)) +! + delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + bnv2bar(i)= 0.0 enddo +!23456===================== ! -! -!====================== we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb +!= we estimate MF-parameters from k= k_mtb to [kref~kpbl] > k_mtb !computation of the mean flow for zobl < z < ztop =sigfac*hprime inb GSL ztop =max(hpbl, ztop) -!===================== - do i = 1,npt +!23456===================== + do i = 1,npt k_mtb = max(1, idxzb(i)) - do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) - if (k < kref(i)) then - j = ipt(i) - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref - vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref - roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - endif - enddo + do k = k_mtb,kbps !kbps = max(kref) kref = (kpbl+1, khtop) + if(k < kref(i)) then + j = ipt(i) + rdelks = del(j,k) * delks(i) + ubar(i) = ubar(i) + rdelks * u1(j,k) + vbar(i) = vbar(i) + rdelks * v1(j,k) + roll(i) = roll(i) + rdelks * ro(i,k) + bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks + endif + enddo enddo ! ! orographic asymmetry parameters (oa), and (clx) [Kim & Arakawa Kim & Doyle] -! +!23456 do i = 1,npt - j = ipt(i) - wdir = atan2(ubar(i),vbar(i)) + pi ! not sure about "+pi" due to "nwdir"-Kim OA/CLX-processing - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) - - clx(i) = clx4(j,mod(nwd-1,4)+1) ! number of "effective" hills in the grid-box KA-95/KD-05 + j = ipt(i) + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) + clx(i) = clx4(j,mod(nwd-1,4)+1) ! number of "effective" hills (?) in the grid-box KA-95/KD-05 ! -!GSLdrag ->identical to above +!GSL-drag ->identical to above ! ! wdir = atan2(ubar(i),vbar(i)) + pi ! idir = mod(nint(fdir*wdir),mdir) + 1 @@ -736,23 +634,22 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) ! ol(i) = ol4(i,mod(nwd-1,4)+1) ! - dtfac(i) = 1.0 - icrilv(i) = .false. ! initialize critical level control Logic - - ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) - xn(i) = ubar(i) / ulow(i) - yn(i) = vbar(i) / ulow(i) + dtfac(i) = 1.0 + icrilv(i) = .false. ! initialize critical level control Logic + ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) + xn(i) = ubar(i) / ulow(i) + yn(i) = vbar(i) / ulow(i) + enddo +!23456 + do k = 1, kmm1 + do i = 1,npt + j = ipt(i) + velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) enddo -! - do k = 1, kmm1 - do i = 1,npt - j = ipt(i) - velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) - enddo enddo - do i = 1,npt - velco(i,km) = velco(i,kmm1) + do i = 1,npt + velco(i,km) = velco(i,kmm1) enddo ! !------------------------------------------------------------------------ @@ -772,94 +669,73 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! ! taub_oro as in KA-95/KD-05 GSL & EMC includes ALL waves (POGWs, Lee-rotors, etc...) ! here taub represents mainly OGWs with nonh_fact = 1. -(kx/kz)**2 -! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered -! +! LLWB for Lee-rotors (downslope dynamics and flow-splitting ) is not considered +!23456 do i = 1,npt - j = ipt(i) - bnv = sqrt( bnv2bar(i) ) - heff = min(hprime(j),hpmax) - - if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac - - if (heff <= 0) cycle - zw1 = ulow(i)/bnv - hsat = fcrit_v1 *zw1 - heff = min(heff, hsat) ! similar hsat-limit in CAM as found in Dec 2020 - - fr = heff/zw1 ! Fr-GSL = Fr * OD -> gamma - - fr = min(fr, frmax) - fr2 = fr*fr - zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) - ! Fr-funct = zw2/(zw2+cg) -! + j = ipt(i) + bnv = sqrt( bnv2bar(i) ) + heff = min(hprime(j),hpmax) + if( zobl(j) > 0.) heff = max(sigfac*heff-zobl(j), 0.)/sigfac + if (heff <= 0) cycle + zw1 = ulow(i)/bnv + hsat = fcrit_v1 *zw1 + heff = min(heff, hsat) + fr = heff/zw1 + fr = min(fr, frmax) + fr2 = fr*fr + zw2 = fr2 *oc(j) ! oc-values from 0 to 10 (GSL => 100) +! ! [Kim & Doyle, 2005] ! - efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream - efact = min( max(efact,efmin), efmax ) - gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 + efact = (oa(i) + 2.) ** (ceofrc*fr) ! enhnancement factor due to the resonance ampification/downstream + efact = min( max(efact,efmin), efmax ) + gfobnv = efact* gmax /(zw2 + cg) ! withoutt "multiplication" on =zw2 ! -! !cleff_max(C768 = 6.28/(12.5 km/5.)) ..... +! ! cleff_max(C768 = 6.28/(12.5 km/5.)) ..... ! xlinv(i) = min(coefm * cleff, cleff_max) ! - mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 - - - xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) - - taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) + mkd05_hills(i) = (1. + clx(i)) ** (oa(i)+1.) ! ex-coefm (1-2) of eff-hills with "some" anizoropy as in KD-2005 + xlinv(i) = min(cleff * mkd05_hills(i), cleff_max) + taub_kd05(i) = roll(i)*xlinv(i) *(gfobnv *zw2)* (zw1 * ulow(i)* ulow(i)) ! ! old: tem = fr2*oc(j) ; gfobnv = gmax * tem / ((tem + cg)*bnv(i)) ! kx =or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge ! - sigres = sigma(j) - inv_b2eff = pi*sigres/heff ! pi2/(2b) - kxridge = pi /ahdxres(i) ! pi2/(2*dx) - xlingfs = max(inv_b2eff, kxridge) -! -! xlinv(i) = max(xlingfs, xlinv(i) ) - - nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 - - if ( nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U + sigres = sigma(j) + inv_b2eff = pi*sigres/heff ! pi2/(2b) + kxridge = pi /ahdxres(i) ! pi2/(2*dx) + xlingfs = max(inv_b2eff, kxridge) + nonh_fact = 1. - xlinv(i)*zw1 * xlinv(i)*zw1 ! 1- (kx/kz)^2 +!23456 + if (nonh_fact <= 0.) cycle ! non-hydrostatic trapping kx = kz = N/U ! - taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact - tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact + taulin(i) = xlinv(i)*roll(i)*bnv*ulow(i)*heff*heff * nonh_fact + tausat(i) = xlinv(i)*roll(i)* zw1*ulow(i)*ulow(i) *fcrit2 * nonh_fact ! -! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => -! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 -! - if ( fr > fcrit_v1 ) then -! - frnd = fr/fcrit_v1 - fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) - taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) - else - taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 - endif - xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 -! - k = max(1, kref(i)-1) - tem = max(velco(i,k)*velco(i,k), dw2min) - scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level Bn2/U2= kz^2 -! -! diagnostics for zogw, tau_ogw -! - zogw(j) = zmeti(j, kref(i) ) - tau_ogw(j) = taub(i) - -! if (kdt == 1) then -! print *, ' tau =', nint(taub(i)*1.e3), ' tkd05 =', nint(taub_kd05(i)*1.e3), 'Fr=', Fr -! print *, ' zogw=', nint(zogw(j)), ' zobl=', nint(zobl(j)) ! nint(mkd05_hills(i)), nint(arhills(i)) -! endif - +! taulin(i) = xlinv(i)*roll(i)*ulow(i)**3/bnv *fr2 => +! fr2 = (bnv*heff/Ulow)**2 + non-hydrostatic trapping effects Fr2_nh = Fr2 - kx2*heff^2 +!23456 + if(fr > fcrit_v1 ) then + frnd = fr/fcrit_v1 + fr_func = frnorm* frnd*frnd/(afr + frnd ** nfr) + taub(i) = tausat(i) *max(fr_func, max_frf) ! nonlinear flux tau0...xlinv(i) + else + taub(i) = taulin(i) ! linear flux for fr <= fcrit_v1 + endif + xlinv(i) = .5*xlinv(i) ! 1/2 rhoint-factor in Ri-solver of PSS-1986 + k = max(1, kref(i)-1) + tem = max(velco(i,k)*velco(i,k), dw2min) + scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level Bn2/U2= kz^2 + zogw(j) = zmeti(j, kref(i) ) + tau_ogw(j) = taub(i) +!23456 enddo ! !----set up bottom values of stress ! - do i = 1,npt + do i = 1,npt taup(i, 1:kref(i) ) = taub(i) - enddo + enddo !====================================================== ! ! Having : taub(i)/tau_ogw(j) => solve for OGW-effects @@ -868,107 +744,85 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & if (strsolver == 'pss-1986') then !====================================================== -! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" -! modified by KD05 with the expression (11):below k=kref ??? +! v0-gfs orogw-solver of Palmer et al 1986 -"pss-1986" +! modified by KD05 with the emp.expression (11):below k=kref ??? ! tau(k+1) = tau(k)*Scorer(K+1)/Scorer(K) -! -! in v1-orogw linsatdis of "wam-2017" -! with llwb-mechanism for -! rotational/non-hydrostat ogws important for +! in v1-orogw linsatdis of "wam-2017" for +! rotational/non-hydrostat ogws; important for ! highres-fv3gfs with dx < 10 km -!====================================================== - - do k = kmps, kmm1 ! vertical level loop from min(kref) - kp1 = k + 1 - - do i = 1, npt - if (k >= kref(i)) then - icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) - endif - enddo +!23456====================================================== + do k = kmps, kmm1 ! vertical level loop from min(kref) + kp1 = k + 1 + do i = 1, npt + if (k >= kref(i)) then + icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) + endif + enddo ! - do i = 1,npt - if (k >= kref(i)) then - if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then - zw1 = max(velco(i,k), velmin) - temv = 1.0 / zw1 + do i = 1,npt + if (k >= kref(i)) then + if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then + zw1 = max(velco(i,k), velmin) + temv = 1.0 / zw1 !=============== -! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB ??? only OA >0 +! Condition for levels below kref(i): k+1 < kref(i)) ??? see KD05 expression (11) for LLWB only OA >0 ! k >= kref(i) and .... k+1 0. .and. kp1 < kref(i)) then - scork = bnv2(i,k) * temv * temv - rscor = min(1.0, scork / scor(i)) - scor(i) = scork - else - rscor = 1. - endif + if (oa(i) > 0. .and. kp1 < kref(i)) then + scork = bnv2(i,k) * temv * temv + rscor = min(1.0, scork / scor(i)) + scor(i) = scork + else + rscor = 1. + endif !=============== - brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface -! xlinv(i)*0.5 - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 - - hd = sqrt(taup(i,k) / tem1) - fro = brvf * hd * temv + brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface + tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k)) *brvf* zw1 + hd = sqrt(taup(i,k) / tem1) + fro = brvf * hd * temv ! ! rim is the "wave"-richardson number byPalmer,Shutts & Swinbank 1986 , PSS-1986 ! - tem2 = sqrt(ri_n(i,k)) - tem = 1. + tem2 * fro - ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) -! -! check Ri-stability to employ the 'dynamical saturation hypothesis' PSS-1986 -! assuming co-existence of Dyn-Ins and Conv-Ins -! - if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then - temc = 2.0 + 1.0 / tem2 - hd = zw1 * (2.*sqrt(temc)-temc) / brvf - taup(i,kp1) = tem1 * hd * hd - else - - taup(i,kp1) = taup(i,k) * rscor - endif + tem2 = sqrt(ri_n(i,k)) + tem = 1. + tem2 * fro + ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) +! +! check Ri-stability to employ the 'dynamical criterion' of PSS-1986 +! assuming co-existence of simultaneous Dyn-Ins and Conv-Ins +! cos(GW_phase) =1 and sin(GW_phase)=-1 +!23456 + if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then + temc = 2.0 + 1.0 / tem2 + hd = zw1 * (2.*sqrt(temc)-temc) / brvf + taup(i,kp1) = tem1 * hd * hd + else + taup(i,kp1) = taup(i,k) * rscor + endif ! - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - endif ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) - endif ! k >= kref(i)) - enddo ! oro-points - enddo ! do k = kmps, kmm1 vertical level loop -! + taup(i,kp1) = min(taup(i,kp1), taup(i,k)) + endif ! if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) + endif ! k >= kref(i)) + enddo ! oro-points + enddo ! do k = kmps, kmm1 vertical level loop +!23456 ! zero momentum deposition at the top model layer: taup(k+1) = taup(k) ! taup(1:npt,km+1) = taup(1:npt,km) ! ! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud -! - do k = 1,km - do i = 1,npt - zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) -!====================================================================================== -! we estimated "impact" of the single sub-grid hill, we have "arhills" in the grid-box -! 2-estimations of "nhills": 1) geometry-arhills and 2) KDO5 mkd05_hills -! for OBL we used: 1) nhills=Grid_Area/Hill_area -! nhills = max(mkd05_hills(i), arhills(i)) -! Trapped "Lee" downslope wave regimes are not properly modelled: vertical shear +NH/Nonlin -! tau(z) = const => tau(z)/m2(z) = const (empirical mesoscale) -! -! Apply dU/dt-limiter -! +!23456 + do k = 1,km + do i = 1,npt + zw1 = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) !====================================================================================== -! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hill_area -! apply limiters for OGW tendency +! zw1 = zw1 * arhills(i) ! simple scale-awareness nhills=Grid_Area/Hil +! apply limiters for OGW tendency !====================================================================================== - if (abs(zw1) > max_axyz ) then - zw1 = sign(max_axyz, zw1) -! if (kdt <=2 ) then -! print *, ' Hdudt ', nint(max_axyz*1.e5), nint(zw2*1.e5) -! print *, ' Hdudt ', xn(i), yn(i) -! endif - endif - taud(i,k)= zw1 - enddo - enddo - + if (abs(zw1) > max_axyz ) zw1 = sign(max_axyz, zw1) + taud(i,k)= zw1 + enddo + enddo +!23456 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ !------if the gravity wave drag would force a critical line in the !------layers below sigma=rlolev during the next deltim timestep, @@ -977,168 +831,140 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb ! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws !2019: this option limits sensitivity of taux/tauy to variations in "taub" -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - do k = 1,kmm1 - do i = 1,npt - - if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then - - if(taud(i,k) /= 0.) then - tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 - dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) -! dtfac(i) = 1.0 - endif - endif - enddo - enddo +!23456~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + do k = 1,kmm1 + do i = 1,npt + if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev .and. taud(i,k) /= 0.) then + tem = dtp * taud(i,k) + dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) +!default : dtfac(i) = 1.0 + endif + enddo + enddo ! -!--------- orogw-solver of gfs PSS-1986 is performed - +!--------- orogw-solver of gfs PSS-1986 is performed else - -!----------- orogw-solver of wam2017 out : taup, taud, pkdis - - dtfac(:) = 1.0 - - call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & - dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & - grav, con_omega, rd, & +!----------orogw-solver of wam2017 out : taup, taud, pkdis + + call oro_spectral_solver(im, km, npt, ipt, kref, kdt, me, master, & + dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & + grav, omega1, rd, & del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) - endif ! oro_linsat - linsatdis-solver for stationary OGWs + endif ! oro_linsat - linsatdis-solver for stationary OGWs ! !---- above orogw-solver of wam2017------------ ! ! tofd as in Beljaars-2004 IFS sep-scale ~5km ! CESM ~ 6km (TMS + OGW/OBL) -! sgh30 = varss of GSL (?) +! sgh30 = varss of GSL ! ---------------------------------------------- - - if( do_tofd ) then -! -! can scale varss(j) by adjusting filterd oro_turb spectra -! a1-coeff by (Lx_flt_cXXX/Lx_c768)^1.9 -! -! klow = 6.28/10km of Beljaars_etal_2004 and kflt^n1 -! kflt = 6.28/18km -! if ( kdt == 1 .and. me == 0) then -! print *, 'ugwp-v1 do_tofd from surface to ', ztop_tofd -! endif - - do i = 1,npt - j = ipt(i) - zpbl = zmet( j, kpbl(j) ) - - sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso - ! GSL-2/limits a) 250 m ; b) var_maxfd =150m - zsurf = zmeti(j,1) - - do k=1,km - zpm(k) = zmet(j,k) - up1(k) = u1(j,k) - vp1(k) = v1(j,k) - enddo +!23456 + if( do_tofd ) then + do i = 1,npt + j = ipt(i) + zpbl = zmet( j, kpbl(j) ) + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso GSL-2/limits a) 250 m ; b) var_maxfd =150m + zsurf = zmeti(j,1) + do k=1,km + zpm(k) = zmet(j,k) + up1(k) = u1(j,k) + vp1(k) = v1(j,k) + enddo - call ugwp_tofd1d(km, cpd, dtp, sigflt, zsurf, zpbl, & - up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + call ugwp_tofd1d(km, cpd, dtp, sigflt, zsurf, zpbl, & + up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - do k=1,km - dudt_ofd(j,k) = utofd1(k) - dvdt_ofd(j,k) = vtofd1(k) + do k=1,km + dudt_ofd(j,k) = utofd1(k) + dvdt_ofd(j,k) = vtofd1(k) ! ! add tofd to gw-tendencies ! - pdvdt(j,k) = pdvdt(j,k) + utofd1(k) - pdudt(j,k) = pdudt(j,k) + vtofd1(k) - pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) - enddo -!2018-diag - du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) - dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) + pdvdt(j,k) = pdvdt(j,k) + utofd1(k) + pdudt(j,k) = pdudt(j,k) + vtofd1(k) + pdtdt(j,k) = pdtdt(j,k) + epstofd1(k) + enddo + du_ofdcol(j) = sum( utofd1(1:km)* del(j,1:km)) + dv_ofdcol(j) = sum( vtofd1(1:km)* del(j,1:km)) - dusfc(j) = dusfc(j) + du_ofdcol(j) - dvsfc(j) = dvsfc(j) + dv_ofdcol(j) - enddo + dusfc(j) = dusfc(j) + du_ofdcol(j) + dvsfc(j) = dvsfc(j) + dv_ofdcol(j) + enddo endif ! do_tofd - +!23456 !-------------------------------------------- ! combine oro-drag effects MB +TOFD + OGWs + diag-3d !-------------------------------------------- -! - +!234546 do k = 1,km - do i = 1,npt - j = ipt(i) -! - eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) -! - if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then + do i = 1,npt + j = ipt(i) + eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) + if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then ! -! if blocking layers -- no ogws +! if blocking layers -- no ogw effects ! - dbim = db(i,k) / (1.+db(i,k)*dtp) - - dudt_obl(j,k) = -dbim * u1(j,k) - dvdt_obl(j,k) = -dbim * v1(j,k) + dbim = db(i,k) / (1.+db(i,k)*dtp) + dudt_obl(j,k) = -dbim * u1(j,k) + dvdt_obl(j,k) = -dbim * v1(j,k) - pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) - pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) -!2018-diag - du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) - dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) - - dusfc(j) = dusfc(j) + du_oblcol(j) - dvsfc(j) = dvsfc(j) + dv_oblcol(j) - - else + pdvdt(j,k) = dudt_obl(j,k) +pdvdt(j,k) + pdudt(j,k) = dvdt_obl(j,k) +pdudt(j,k) + du_oblcol(j) = du_oblcol(j) + dudt_obl(j,k)* del(j,k) + dv_oblcol(j) = dv_oblcol(j) + dvdt_obl(j,k)* del(j,k) + dusfc(j) = dusfc(j) + du_oblcol(j) + dvsfc(j) = dvsfc(j) + dv_oblcol(j) +!23456 + else ! ! ogw-s above blocking height ! - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) ! - dudt_ogw(j,k) = dtaux - dvdt_ogw(j,k) = dtauy + dudt_ogw(j,k) = dtaux + dvdt_ogw(j,k) = dtauy ! - pdvdt(j,k) = dtauy +pdvdt(j,k) - pdudt(j,k) = dtaux +pdudt(j,k) + pdvdt(j,k) = dtauy +pdvdt(j,k) + pdudt(j,k) = dtaux +pdudt(j,k) ! - du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) - dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) + du_ogwcol(j) = du_ogwcol(j) + dtaux * del(j,k) + dv_ogwcol(j) = dv_ogwcol(j) + dtauy * del(j,k) ! - dusfc(j) = dusfc(j) + du_ogwcol(j) - dvsfc(j) = dvsfc(j) + dv_ogwcol(j) - endif + dusfc(j) = dusfc(j) + du_ogwcol(j) + dvsfc(j) = dvsfc(j) + dv_ogwcol(j) + endif +!23456 !============ ! local energy deposition sso-heat due to loss of kinetic energy !============ - unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp - vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp - eng1 = 0.5*(unew*unew + vnew*vnew) - pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) - - enddo + unew = u1(j,k) + pdudt(j,k)*dtp ! pdudt(j,k)*dtp + vnew = v1(j,k) + pdvdt(j,k)*dtp ! pdvdt(j,k)*dtp + eng1 = 0.5*(unew*unew + vnew*vnew) + pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt + pdtdt(j,k) + enddo enddo ! dusfc w/o tofd sign as in the era-i, merra and cfsr +!23456 do i = 1,npt - j = ipt(i) - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) + j = ipt(i) + dusfc(j) = -rgrav * dusfc(j) + dvsfc(j) = -rgrav * dvsfc(j) du_ogwcol(j) = -rgrav *du_ogwcol (j) dv_ogwcol(j) = -rgrav *dv_ogwcol (j) du_oblcol(j) = -rgrav *du_oblcol (j) dv_oblcol(j) = -rgrav *dv_oblcol (j) - tau_ogw(j) = -rgrav * tau_ogw(j) - du_ofdcol(j) = -rgrav * du_ofdcol(j) - dv_ofdcol(j) = -rgrav * du_ofdcol(j) + du_ofdcol(j) = -rgrav * du_ofdcol(j) + dv_ofdcol(j) = -rgrav * du_ofdcol(j) enddo - return + return -!============ debug ------------------------------------------------ +!============ print/debug after the RETURN statenemt -------------------------------- if (kdt <= 2 .and. me == 0) then print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me ! @@ -1185,12 +1011,12 @@ end subroutine orogw_v1 subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd + use machine , only : kind_phys + use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd ! ! adding the implicit tendency estimate ! - implicit none + implicit none integer, intent(in) :: levs real(kind_phys), intent(in) :: con_cp real(kind_phys), intent(in) :: dtp @@ -1198,16 +1024,15 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & real(kind_phys), intent(in), dimension(levs) :: u, v, zmid real(kind_phys), intent(in) :: sigflt, zpbl, zsurf - real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd - - + real(kind_phys), intent(out), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd ! ! locals ! integer :: i, k real(kind=kind_phys) :: rcpd2, tofd_mag, tofd_zdep - real(kind_phys) :: unew, vnew, eknew - real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer + real(kind_phys) :: unew, vnew, eknew + + real(kind=kind_phys), parameter :: sghmax = 5. ! dz(1)/5= 25/5 m dz-of the first layer real(kind=kind_phys), parameter :: tend_imp = 1. @@ -1222,10 +1047,10 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & ! H_efold = min(H_efold,1500.) rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! dz ~25m of the first layer in FV3GFS-127L + tofd_mag = const_tofd * a12_tofd * sgh2 ! * scale_res -! GSL-scheme: varmax_fd, beta_fd ,250. +! GSL-darg scheme: varmax_fd, beta_fd ,250. ! var_temp = MIN(varss,varmax_fd) + MAX(0., 0.1*(varss-varmax_fd)) ! var_temp = MIN(var_temp, 250.) ! var_temp = var_temp * var_temp @@ -1257,7 +1082,7 @@ subroutine ugwp_tofd1d(levs, con_cp, dtp, sigflt, zsurf, zpbl, u, v, & krf = umag * tofd_mag * tofd_zdep if (tend_imp == 1.) then - krf = krf/(1.+krf*dtp) + krf = krf/(1.+krf*dtp) endif utofd(k) = -krf*u(k) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index ad8f8090d..07330cf8b 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -10,16 +10,10 @@ module cires_ugwpv1_solv2 ! reflected GWs treated as waves with "negligible" flux, ! they are out of given column !--------------------------------------------------- -! call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & -! tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & -! zmet, zmeti,prslk, xlat_d, sinlat, coslat, & -! con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & -! dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- @@ -56,8 +50,6 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! implicit none ! - real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt - real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 integer, parameter :: ener_norm =0 @@ -201,23 +193,22 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & iPr_max = max(1.0, iPr_ktgw) gipr = grav* Ipr_ktgw ! -! test for input fields -! - if (mpi_id == master .and. kdt < -2) then - print *, im, levs, dtp, kdt, ' vay-solv2-v1' - print *, minval(tm), maxval(tm), ' min-max-tm ' - print *, minval(vm), maxval(vm), ' min-max-vm ' - print *, minval(um), maxval(um), ' min-max-um ' - print *, minval(qm), maxval(qm), ' min-max-qm ' - print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' - print *, minval(prsi), maxval(prsi), ' min-max-Pint ' - print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' - print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' - print *, minval(prslk), maxval(prslk), ' min-max-Exner ' - print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' - print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! test for input fields +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' ! - endif +! endif if (idebug_gwrms == 1) then tauabs=0.0; wrms =0.0 ; trms =0.0 @@ -234,7 +225,9 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & km1 = ksrc - 1 kp1 = ksrc + 1 ktop= levs+1 - suprf(ktop) = kion(levs) + + suprf(ktop) = kion(levs) + do k=1,levs suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 pdvdt(:,k) = 0.0 @@ -246,8 +239,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & !----------------------------------------------------------- ! column-based j=1,im pjysics with 1D-arrays !----------------------------------------------------------- - DO j=1, im - + DO j=1, im jl =j tx1 = omega2 * sinlat(j) *rv_kxw cf1 = abs(tx1) @@ -302,26 +294,26 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! interface mean flow parameters launch -> levs+1 ! --------------------------------------------- do jk= km1,levs - tvc = atm(jk) * (1. +fv*aqm(jk)) - tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) + tvc = atm(jk)*(1. +fv*aqm(jk)) + tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) ptc = tvc/ prslk(jl, jk) ptm = tvm/prslk(jl,jk-1) ! - zthm = 2.0 / (tvc+tvm) + zthm = 2.0/(tvc+tvm) rhp_wam = zthm*gor !interface - uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) - vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) - tint(jk) = 0.5 *(tvc+tvm) + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) rhomid(jk) = aprsl(jk)*rdi/atm(jk) rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) zdelp = dz_meti(jk) ! >0 ...... dz-meters v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters ! -! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) ! - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) bn(jk) = sqrt(bn2(jk)) @@ -1015,7 +1007,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! RETURN -!================================= +!================================= diag print after "return" ====================== if (kdt ==1 .and. mpi_id == master) then ! print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 index 98eca419e..c840b49d8 100644 --- a/physics/cires_ugwpv1_sporo.F90 +++ b/physics/cires_ugwpv1_sporo.F90 @@ -1,10 +1,11 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & - grav, omega, con_rd, del, sigma, hprime, gamma, theta, & + del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) ! - USE MACHINE , ONLY : kind_phys + use machine , only : kind_phys + use ugwp_common, only : grav, omega2, rd ! implicit none @@ -24,7 +25,6 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & real(kind=kind_phys), intent(in), dimension(im, levs) :: & u1, v1, t1, bn2, rho, prsl, del - real(kind=kind_phys), intent(in) :: grav, omega, con_rd real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi ! @@ -44,7 +44,7 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin real(kind=kind_phys), parameter :: kedmin = 1.e-3 real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 - real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec + real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec real(kind=kind_phys), parameter :: Linsat2 =0.5 real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 @@ -124,12 +124,12 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & wkdis(:,:) = kedmin call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & - & prsi(j,:), prsL(j,:), grav, con_rd, & + & prsi(j,:), prsL(j,:), & & del(j,:), rho(i,:), & & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & & xn(i), yn(i)) - fcor2 = (2*omega*sinlat(j))*(2*omega*sinlat(j))*fc_flag + fcor2 = omega2*sinlat(j)*omega2*sinlat(j)*fc_flag k = ksrc @@ -152,11 +152,11 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & ! ! if (cxoro(iw) > cxmin) then - wave_act(iw,k:levs+1) = 0. ! crit-level + wave_act(iw,k:levs+1) = 0. ! crit-level else cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) if ( cdf2(iw) < cxmin2) then - wave_act(iw,k:levs+1) = 0. ! coriolis cut-off + wave_act(iw,k:levs+1) = 0. ! coriolis cut-off else kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) kzw = sqrt(kzw2) @@ -199,7 +199,7 @@ subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & wave_act(iw,k:levs+1) = 0.0 else ! -! upward propagation w/o reflection +! upward propagation w/o reflection effects ! kxw = akx(iw) kzw = sqrt(kzw2) @@ -283,18 +283,17 @@ end subroutine oro_spectral_solver ! !------------------------------------------------------------- subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & - & grav, con_rd, & - & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) + & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) use machine , only : kind_phys - use ugwp_common , only : velmin, dw2min + use ugwp_common , only : velmin, dw2min, rdi, grav, rgrav, hpscale, rhp, rh4 implicit none - + integer :: nz, nzi real(kind=kind_phys), dimension(nz ) :: u1, v1, t1, delp, rho, pmid real(kind=kind_phys), dimension(nz ) :: bn2 ! define at the interfaces real(kind=kind_phys), dimension(nz+1) :: pint real(kind=kind_phys) :: xn, yn - real(kind=kind_phys),intent(in) :: grav, con_rd + ! output real(kind=kind_phys), dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp @@ -303,24 +302,23 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & integer :: i, j, k real(kind=kind_phys) :: ui, vi, ti, uz, vz, shr2, rdz, kamp real(kind=kind_phys) :: zgrow, zmet, rdpm, ritur, kmol, w1 - real(kind=kind_phys) :: rgrav, rdi + ! paremeters - real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 - real(kind=kind_phys), parameter :: rhps=1.0/hps - real(kind=kind_phys), parameter :: h4= 0.25/hps - real(kind=kind_phys), parameter :: rimin = 1.0/8.0, kedmin = 0.01 - real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 +! real(kind=kind_phys), parameter :: hps = 7000., rpspa = 1.e-5 +! real(kind=kind_phys), parameter :: rhps=1.0/hps +! real(kind=kind_phys), parameter :: h4= 0.25/hps + + real(kind=kind_phys), parameter :: rimin = 0.125, kedmin = 0.01 + real(kind=kind_phys), parameter :: lturb = 30. , uturb = 150.0 real(kind=kind_phys), parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb - kalp(1:nzi) = 2.e-7 ! radiative damping - - rgrav = 1.0/grav - rdi = 1.0/con_rd + + kalp(1:nzi) = 2.e-7 ! radiative damping scale do k=2, nz rdpm = grav/(pmid(k-1)-pmid(k)) ui = .5*(u1(k-1)+u1(k)) vi = .5*(v1(k-1)+v1(k)) - uzi(k) = Ui*xn + Vi*yn + uzi(k) = ui*xn + vi*yn ti = .5*(t1(k-1)+t1(k)) rhoi(k) = rdi*pint(k)/ti rdz = rdpm *rhoi(k) @@ -328,13 +326,13 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & uz = u1(k)-u1(k-1) vz = v1(k)-v1(k-1) shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - zmet = -hps*alog(pint(k)*rpspa) - zgrow = exp(zmet*h4) - kmol = 2.e-5*exp(zmet*rhps)+kedmin + zmet = -hpscale*alog(pint(k)*1.e-5) + zgrow = exp(zmet*rh4) + kmol = 2.e-5*exp(zmet*rhp) + kedmin ritur = max(bn2(k)/shr2, rimin) kamp = sqrt(shr2)*lsc2 *zgrow w1 = 1./(1. + 5*ritur) - ktur(k) = kamp * w1 * w1 +kmol + ktur(k) = kamp * w1 * w1 + kmol enddo k = 1 diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 index db95a4f87..3c42e573b 100644 --- a/physics/cires_ugwpv1_triggers.F90 +++ b/physics/cires_ugwpv1_triggers.F90 @@ -4,7 +4,6 @@ module cires_ugwpv1_triggers contains - ! ! ! @@ -177,87 +176,8 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5 - - subroutine init_nazdir(con_pi, naz, xaz, yaz) - implicit none - real(kind=kind_phys) :: con_pi - integer :: naz - real(kind=kind_phys), dimension(naz) :: xaz, yaz - integer :: idir - real(kind=kind_phys) :: phic, drad - real(kind=kind_phys) :: pi2 - pi2 = 2.0*con_pi - drad = pi2/float(naz) - if (naz.ne.4) then - do idir =1, naz - Phic = drad*(float(idir)-1.0) - xaz(idir) = cos(Phic) - yaz(idir) = sin(Phic) - enddo - else -! if (naz.eq.4) then - xaz(1) = 1.0 !E - yaz(1) = 0.0 - xaz(2) = 0.0 - yaz(2) = 1.0 !N - xaz(3) =-1.0 !W - yaz(3) = 0.0 - xaz(4) = 0.0 - yaz(4) =-1.0 !S - endif - end subroutine init_nazdir -!========================================================================= -! Below subroutine that can be activated after "testing" and extra-work" -!========================================================================= - subroutine emc_modulation(im , levs, ntke, tau_ngw, cdmb3, cdmb4, dtp, & - q_tke, dqdt_tke, del, rain) - - integer, intent(in) :: im , levs, ntke - real(kind=kind_phys), intent(in) :: cdmb3, cdmb4, dtp - real(kind=kind_phys), intent(in) :: rain(im) - real(kind=kind_phys), intent(inout) :: tau_ngw(im) - real(kind=kind_phys), intent(in), dimension(im,levs) :: q_tke, dqdt_tke, del - -! locals - - - real(kind=kind_phys) :: turb_fac, tem - real(kind=kind_phys) :: rfac, tx1, tke - + end subroutine slat_geos5 -!============ -! -! below the "EMC-proposal" in May 2019 without rigorous tests reported elsewhere -! can be eliminated due to "lack" of validations and -! in GFSv16 cdmbgwd(3) =1.0 and the next if-loop is "cosmetic" proposal -! -!============ - if (1.0-cdmb3 > 1.0e-6) then - rfac = 86400000. / dtp !??? -! -! in operations cdmbgwd(3) = 1 in GFSv16, and code below is not executed -! - if (cdmb4 > 0.0) then - do i=1,im - turb_fac = 0.0 - if (ntke > 0) then - tem = 0.0 - do k=1,(levs+levs)/3 ! ???? - tke = q_tke(i,k) + dqdt_tke(i,k) * dtp - turb_fac = turb_fac + del(i,k) * tke - tem = tem + del(i,k) - enddo - turb_fac = turb_fac / tem - endif - tx1 = cdmb4*min(10.0, max(turb_fac,rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) * cdmb3 !???? - enddo - endif - endif - end subroutine emc_modulation - - !=============================================== ! ! Spontaneous GW triggers by dynamical inbalances (OKW, fronts/jets, and convection) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 252838ca1..20ab38897 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -37,22 +37,14 @@ module ugwpv1_gsldrag use machine, only: kind_phys + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 - use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp - use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa - use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 - use cires_ugwpv1_oro, only: orogw_v1 -! use cires_ugwp1_sporo, only: oro_spectral_solver - - use drag_suite, only: drag_suite_run - -! use cires_ugwpv1_triggers, only: get_spectra_tau_convgw, get_spectra_tau_okw, get_spectra_tau_nstgw -! use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 -! use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 -! use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 -! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize -! use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp -! use gwdps, only: gwdps_run + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 + + use drag_suite, only: drag_suite_run implicit none @@ -77,10 +69,13 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) + use ugwp_common + !---- initialization of unified_ugwp implicit none @@ -97,6 +92,7 @@ subroutine ugwpv1_gsldrag_init ( & real(kind=kind_phys), intent (in) :: dtp real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt logical, intent (in) :: do_ugwp logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & @@ -118,12 +114,32 @@ subroutine ugwpv1_gsldrag_init ( & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 -!============================================= -! 3 cases for ORO-schemes + NGWs: -! gwd_opt => "1 and 2, 3, 22, 33' +!============================================================================ +! +! gwd_opt => "1 and 2, 3, 22, 33' see previous GSL-commits +! related to GSL-oro drag suite +! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography +! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 +! FV3GFS_io.F90: if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & +! FV3GFS_io.F90: Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then +! FV3GFS_io.F90: if ( (Model%gwd_opt==3 .or. Model%gwd_opt==33) .or. & +! FV3GFS_io.F90: ( (Model%gwd_opt==2 .or. Model%gwd_opt==22) .and. & +! +! gwd_opt=1 -current 14-element GFS-EMC subgrid-oro input +! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input +! GSL uses the gwd_opt flag to control "extra" diagnostics (22 and 33) +! CCPP may use gwd_opt to determine 14 or 24 variables for the input +! but at present you work with "nmtvr" +! GFS_GWD_generic.F90: integer, intent(in) :: im, levs, nmtvr +!GFS_GWD_generic.F90: real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) +!GFS_GWD_generic.F90: if (nmtvr == 14) then ! gwd_opt=1 current operational - as of 2014 +!GFS_GWD_generic.F90: elseif (nmtvr == 10) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 6) then ???? +!GFS_GWD_generic.F90: elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp gwd_opt=2,3 +! ! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 -! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp -!============================================= +! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp +!============================================================================== ! Test to make sure that at most only one large-scale/blocking ! orographic drag scheme is chosen if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & @@ -140,7 +156,7 @@ subroutine ugwpv1_gsldrag_init ( & return end if - +! if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only @@ -149,6 +165,7 @@ subroutine ugwpv1_gsldrag_init ( & errflg = 1 return endif +! if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag @@ -159,7 +176,57 @@ subroutine ugwpv1_gsldrag_init ( & errflg = 1 return endif - if (is_initialized) return +!========================== +! +! initialize ugwp_common +! con_pi, con_rerth, con_p0, con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt +! +!========================== + + pi = con_pi + arad = con_rerth + p0s = con_p0 + grav = con_g + omega1= con_omega + cpd = con_cp + rd = con_rd + rv = con_rv + fv = con_fvirt + + grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav + rdi = 1.0 / rd ; rcpd = 1./cpd; rcpd2 = 0.5/cpd + gor = grav/rd + gr2 = grav*gor + grcp = grav*rcpd + gocp = grcp + rcpdl = cpd*rgrav + grav2cpd = grav*grcp + + pi2 = 2.*pi ; pih = .5*pi + rad_to_deg=180.0/pi + deg_to_rad=pi/180.0 + + bnv2min = (pi2/1800.)*(pi2/1800.) + bnv2max = (pi2/30.)*(pi2/30.) + dw2min = 1.0 + velmin = sqrt(dw2min) + minvel = 0.5 + + omega2 = 2.*omega1 + omega3 = 3.*omega1 + + hpscale = 7000. ; hpskm = hpscale*1.e-3 + rhp = 1./hpscale + rhp2 = 0.5*rhp; rh4 = 0.25*rhp + rhp4 = rhp2 * rhp2 + khp = rhp* rd/cpd + mkzmin = pi2/80.0e3 + mkz2min = mkzmin*mkzmin + mkzmax = pi2/500. + mkz2max = mkzmax*mkzmax + cdmin = 2.e-2/mkzmax + + rcpdt = rcpd/dtp if ( do_ugwp_v1 ) then call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & @@ -177,7 +244,9 @@ subroutine ugwpv1_gsldrag_init ( & print *, ' ccpp: ugwpv1_gsldrag_init ' endif + + is_initialized = .true. @@ -238,7 +307,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & - con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & +! con_g, con_omega, con_pi, con_cp, con_rd, con_rv, con_rerth, con_fvirt, & nmtvr, hprime, oc, theta, sigma, gamma, elvmax, clx, oa4, & varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & rain, br1, hpbl, kpbl, slmsk, & @@ -252,32 +321,31 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & lprnt, ipr, errmsg, errflg) - -! old data: jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & -! cap: dt3dt(i,k) = dt3dt(i,k) - dtdt(i,k)*dtf -! ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside ! -! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta -! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 -! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 -!######################################################################## -![ccpp-table-properties] -! name = GFS_interstitial_type -! type = ddt +! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta +! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" !######################################################################## -! -! + +! + + use ugwp_common, only : con_pi => pi, con_g => grav, con_rd => rd, & + con_rv => rv, con_cp => cpd, con_fv => fv, & + con_rerth => arad, con_omega => omega1, rgrav + implicit none -! Preference use (im,levs) rather than (:,:) to avoid memory-leaks -! order description control-logical -! other in-variables -! out-variables -! local-variables -! unified diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 +! Preference use (im,levs) rather than (:,:) to avoid memory-leaks +! that found in Nov-Dec 2020 +! order array-description control-logical +! other in-variables +! out-variables +! local-variables +! +! unified GSL and CIRES diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 ! ! ! interface variables @@ -298,9 +366,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd integer, intent(in) :: kdt, jdat(8) ! SSO parameters and variables - integer, intent(in) :: gwd_opt + integer, intent(in) :: gwd_opt !gwd_opt and nmtvr are "redundant" controls integer, intent(in) :: nmtvr - real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! in gsl_drag + real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! for gsl_drag real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma @@ -311,13 +379,13 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(in), dimension(im, 4) :: oa4ss,ol4ss !===== -!ccpp-style passing constants +!ccpp-style passing constants, I prefer to take them out from the "call-subr" list !===== - real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & - con_rv, con_rerth, con_fvirt +! real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & +! con_rv, con_rerth, con_fvirt ! grids - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area + real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area ! State vars + PBL/slmsk +rain @@ -392,9 +460,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! switches that activate impact of OGWs and NGWs ! integer :: nmtvr_temp - - real(kind=kind_phys) :: inv_g - + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces @@ -419,13 +485,12 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! for all oro-suites can uze geo-meters having "hpbl" ! - inv_g = 1./con_g ! ! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust ! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" ! - zmeti = phii*inv_g - zmet = phil*inv_g + zmeti = phii* rgrav + zmet = phil* rgrav !=============================================================== ! ORO-diag @@ -452,8 +517,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. !=============================================================== -! Accumulated tendencies due to 3-SSO schemes (all ORO-physics) -! ogw + obl +oss +ofd ..... no explicit "lee wave trapping" +! diag tendencies due to all-SSO schemes (ORO-physics) +! ogw + obl + oss + ofd ..... no explicit "lee wave trapping" !=============================================================== do k=1,levs do i=1,im @@ -464,25 +529,18 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo ! -! ------------------ -! -! Also zero all ORO diag-c arrays to avoid "special ifs and zeros" -! like old GFS-ORO gwdps_run has limited diagnostics -! -! ------------------ - ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd & .or. do_ugwp_v1_w_gsldrag) then ! -! the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : +! to do: the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : ! ! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd ! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol ! dusfcg, dvsfcg -! gsd_diss_ht_opt =0 => Pdtdt = bl+ls +(Pdtdt=0) +! ! call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & ugrs,vgrs,tgrs,q1, & @@ -494,21 +552,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dusfcg, dvsfcg, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_osscol, dv_osscol, du_ofdcol, dv_ofdcol, & - slmsk,br1,hpbl,con_g,con_cp,con_rd,con_rv, & - con_fvirt,con_pi,lonr, & + slmsk,br1,hpbl, con_g,con_cp,con_rd,con_rv, & + con_fv, con_pi, lonr, & cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) ! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol ! - if (kdt <= 2 .and. me == master) then - print *, ' unified drag_suite_run ', kdt - print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 - print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 - +! if (kdt <= 2 .and. me == master) then +! print *, ' unified drag_suite_run ', kdt +! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! ! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 - +! ! if (gwd_opt == 22 .or. gwd_opt == 33) then ! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 ! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 @@ -519,7 +577,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 ! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 ! endif - endif +! endif else ! @@ -539,8 +597,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & - con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & - con_rerth, con_fvirt,xlat_d, sinlat, coslat, area, & + xlat_d, sinlat, coslat, area, & cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & sigma, gamma, elvmax, sgh30, kpbl, ugrs, & vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & @@ -553,21 +610,20 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms ! ! - if (kdt <= 2 .and. me == master) then +! if (kdt <= 2 .and. me == master) then +! +! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr +! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! endif - print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr - print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 - print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 - print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 - print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 - print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 - endif - -! pdudt = 0.0*pdudt ; pdvdt = 0.0*pdvdt ; pdtdt = 0. end if ! -! GFS-style diag dt3dt(:.:, 1:14) +! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections ! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs @@ -591,14 +647,11 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !================================================================== ! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) ! -! updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs +! 2020 updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs !================================================================== - call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) -! if (me == master) then -! print *, ' ugwpv1 forcing ', maxval(tau_ngw), minval(tau_ngw) -! print *, ' ugwpv1 forcing tamp_mpa ', tamp_mpa -! endif + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) + y4 = jdat(1); month = jdat(2); day = jdat(3) ! ! hour = jdat(5) @@ -616,23 +669,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & zmet, zmeti,prslk, xlat_d, sinlat, coslat, & - con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt, & dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) - - - if (me == master .and. kdt <= 2) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' +! +! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt +! +! if (me == master .and. kdt <= 2) then +! print * +! write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' ! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - - print *, ' ugwp_v1 ', kdt - print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 - print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 - print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 - - - endif +! print * +! +! print *, ' ugwp_v1 ', kdt +! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 +! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 +! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 +! endif end if ! do_ugwp_v1 @@ -657,10 +708,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dvdt_gw = Pdvdt +dvdt_ngw dtdt_gw = Pdtdt +dtdt_ngw kdis_gw = Pkdis +kdis_ngw -! -! add to previous phys-tendencies -! ?-accumulation of GFS ( pbl + gw =0 rf should be taken out from physics, inside FV3-dycore) - +! +! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) +! dudt = dudt + dudt_ngw dvdt = dvdt + dvdt_ngw dtdt = dtdt + dtdt_ngw diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 73d717f78..1cfec2104 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -64,6 +64,8 @@ units = none dimensions = (8) type = integer + intent = in + optional = F [lonr] standard_name = number_of_equatorial_longitude_points long_name = number of global points in x-dir (i) along the equator @@ -142,6 +144,60 @@ kind = kind_phys intent = in optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_omega] + standard_name = angular_velocity_of_earth + long_name = angular velocity of earth + units = s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [do_ugwp] standard_name = do_ugwp long_name = flag to activate CIRES UGWP @@ -445,78 +501,6 @@ type = integer intent = in optional = F -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_omega] - standard_name = angular_velocity_of_earth - long_name = angular velocity of earth - units = s-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat !of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_rd] - standard_name = gas_constant_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_rv] - standard_name = gas_constant_water_vapor - long_name = ideal gas constant for water vapor - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_rerth] - standard_name = radius_of_earth - long_name = radius of earth - units = m - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[con_fvirt] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [nmtvr] standard_name = number_of_statistical_measures_of_subgrid_orography long_name = number of topographic variables in GWD From a5547cb6785de3c990a62bb3ee5aea5fa32a93be Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 26 Jan 2021 10:50:39 -0700 Subject: [PATCH 53/67] Fix formatting in physics/GFS_phys_time_vary.fv3.F90 --- physics/GFS_phys_time_vary.fv3.F90 | 48 ++++++++++++++++-------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 04f191fdf..b0f88695b 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -81,7 +81,6 @@ subroutine GFS_phys_time_vary_init ( integer, intent(inout) :: jindx1_ci(:), jindx2_ci(:), iindx1_ci(:), iindx2_ci(:) real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) - logical, intent(in) :: do_ugwp_v1 real(kind_phys), intent(inout) :: ddy_j1tau(:), ddy_j2tau(:) integer, intent(inout) :: jindx1_tau(:), jindx2_tau(:) @@ -108,7 +107,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & -!$OMP shared (do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau) & +!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & !$OMP private (ix,i,j) !$OMP sections @@ -185,11 +184,13 @@ subroutine GFS_phys_time_vary_init ( ! No consistency check needed for in/ccn data, all values are ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP section + +!$OMP section !> - Call tau_amf dats for ugwp_v1 - if (do_ugwp_v1) then - call read_tau_amf(me, master, errmsg, errflg) - endif + if (do_ugwp_v1) then + call read_tau_amf(me, master, errmsg, errflg) + endif + !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") @@ -224,12 +225,14 @@ subroutine GFS_phys_time_vary_init ( jindx2_ci, ddy_ci, xlon_d, & iindx1_ci, iindx2_ci, ddx_ci) endif + !$OMP section !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs if (do_ugwp_v1) then call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & ddy_j1tau, ddy_j2tau) endif + !$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 @@ -292,7 +295,7 @@ subroutine GFS_phys_time_vary_timestep_init ( tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & - do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) + do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -316,19 +319,17 @@ subroutine GFS_phys_time_vary_timestep_init ( real(kind_phys), intent(in) :: prsl(:,:) integer, intent(in) :: seed0 real(kind_phys), intent(inout) :: rann(:,:) - + logical, intent(in) :: do_ugwp_v1 integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) - real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) - real(kind_phys), intent(inout) :: tau_amf(:) - + real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) + real(kind_phys), intent(inout) :: tau_amf(:) + ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) - logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & @@ -337,7 +338,7 @@ subroutine GFS_phys_time_vary_timestep_init ( facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & - snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -431,13 +432,14 @@ subroutine GFS_phys_time_vary_timestep_init ( iindx2_ci, ddx_ci, & levs, prsl, in_nm, ccn_nm) endif - + !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that resolve GW-activ if (do_ugwp_v1) then - call tau_amf_interp(me, master, im, idate,fhour, & - jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf) + call tau_amf_interp(me, master, im, idate, fhour, & + jindx1_tau, jindx2_tau, & + ddy_j1tau, ddy_j2tau, tau_amf) endif - + !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN @@ -512,12 +514,12 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (allocated(ciplin) ) deallocate(ciplin) if (allocated(ccnin) ) deallocate(ccnin) if (allocated(ci_pres) ) deallocate(ci_pres) - - ! Deallocate UGWP-input arrays - if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) - if (allocated (tau_limb)) deallocate (tau_limb) + + ! Deallocate UGWP-input arrays + if (allocated (ugwp_taulat)) deallocate(ugwp_taulat) + if (allocated (tau_limb)) deallocate (tau_limb) if (allocated (days_limb)) deallocate(days_limb) - + is_initialized = .false. end subroutine GFS_phys_time_vary_finalize From 2b4489a9a9a8a90bcf8e06f725e625da3f0bd0af Mon Sep 17 00:00:00 2001 From: "valery.yudin" Date: Thu, 28 Jan 2021 13:32:21 -0500 Subject: [PATCH 54/67] compiling all 3 GW suites --- physics/cires_orowam2017.f | 57 +- physics/cires_ugwp.F90 | 29 +- physics/cires_ugwp.meta | 5 +- physics/cires_ugwp_initialize.F90 | 317 +------- physics/cires_ugwp_initialize_v1.F90 | 805 -------------------- physics/cires_ugwp_module.F90 | 473 +----------- physics/cires_ugwp_module_v1.F90 | 672 ----------------- physics/cires_ugwp_ngw_utils.F90 | 73 -- physics/cires_ugwp_orolm97_v1.F90 | 1008 ------------------------- physics/cires_ugwp_solv2_v1_mod.F90 | 829 -------------------- physics/cires_ugwp_solvers.F90 | 664 ---------------- physics/cires_ugwp_triggers.F90 | 483 +----------- physics/cires_ugwp_triggers_v1.F90 | 584 -------------- physics/cires_ugwp_utils.F90 | 152 ---- physics/cires_ugwpv1_triggers.F90 | 36 - physics/cires_vert_lsatdis.F90 | 524 ------------- physics/cires_vert_orodis.F90 | 1018 ------------------------- physics/cires_vert_orodis_v1.F90 | 1047 -------------------------- physics/cires_vert_wmsdis.F90 | 425 ----------- physics/ugwp_driver_v0.F | 678 +---------------- physics/ugwpv1_gsldrag.F90 | 30 +- physics/unified_ugwp.F90 | 136 +--- physics/unified_ugwp.meta | 51 +- 23 files changed, 180 insertions(+), 9916 deletions(-) delete mode 100644 physics/cires_ugwp_initialize_v1.F90 delete mode 100644 physics/cires_ugwp_module_v1.F90 delete mode 100644 physics/cires_ugwp_ngw_utils.F90 delete mode 100644 physics/cires_ugwp_orolm97_v1.F90 delete mode 100644 physics/cires_ugwp_solv2_v1_mod.F90 delete mode 100644 physics/cires_ugwp_solvers.F90 delete mode 100644 physics/cires_ugwp_triggers_v1.F90 delete mode 100644 physics/cires_ugwp_utils.F90 delete mode 100644 physics/cires_vert_lsatdis.F90 delete mode 100644 physics/cires_vert_orodis.F90 delete mode 100644 physics/cires_vert_orodis_v1.F90 delete mode 100644 physics/cires_vert_wmsdis.F90 diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f index 4170a3d79..c20f98f42 100644 --- a/physics/cires_orowam2017.f +++ b/physics/cires_orowam2017.f @@ -4,7 +4,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & sinlat, xlatd, taup, taud, pkdis) ! USE MACHINE , ONLY : kind_phys - use ugwp_common , only : grav, omega2 + use ugwp_common_v0 , only : grav, omega2 ! implicit none @@ -121,7 +121,7 @@ subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, taub_kx(1:nw) = tau_kx(1:nw) * taub(i) wkdis(:,:) = kedmin - call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), + call oro_meanflow_v0(levs, nzi, u1(j,:), v1(j,:), t1(j,:), & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, & xn(i), yn(i)) @@ -275,10 +275,10 @@ end subroutine oro_wam_2017 ! define mean flow and dissipation for OGW-kx spectrum ! !------------------------------------------------------------- - subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, + subroutine oro_meanflow_v0(nz, nzi, u1, v1, t1, pint, pmid, & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) - use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min + use ugwp_common_v0 , only : grav, rgrav, rdi, velmin, dw2min implicit none integer :: nz, nzi @@ -336,4 +336,51 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, rhoi(k) = rhoi(k-1)*.5 dzi(k) = dzi(k-1) - end subroutine oro_meanflow + end subroutine oro_meanflow_v0 + + subroutine ugwpv0_tofd1d(levs, sigflt, elvmax, zsurf, + & zpbl, u, v, zmid, utofd, vtofd, epstofd, krf_tofd) + use machine , only : kind_phys + use ugwp_common_v0 , only : rcpd2 + use ugwpv0_oro_init, only : n_tofd, const_tofd, ze_tofd + use ugwpv0_oro_init, only : a12_tofd, ztop_tofd +! + implicit none + integer :: levs + real(kind_phys), dimension(levs) :: u, v, zmid + real(kind_phys) :: sigflt, elvmax, zpbl, zsurf + real(kind_phys), dimension(levs) :: utofd, vtofd + real(kind_phys), dimension(levs) :: epstofd, krf_tofd +! +! locals +! + integer :: i, k + real(kind_phys) :: sghmax = 5. + real(kind_phys) :: sgh2, ekin, zdec, rzdec, umag, zmet + real(kind_phys) :: zarg, ztexp, krf +! + utofd =0.0 ; vtofd = 0.0 + epstofd =0.0 ; krf_tofd =0.0 +! + zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl + zdec = min(ze_tofd, zdec) ! cannot exceed 18 km + rzdec = 1.0/zdec + sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer + + do k=1, levs + zmet = zmid(k)-zsurf + if (zmet > ztop_tofd) cycle + ekin = u(k)*u(k) + v(k)*v(k) + umag = sqrt(ekin) + zarg = zmet*rzdec + ztexp = exp(-zarg*sqrt(zarg)) + krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp + + utofd(k) = -krf*u(k) + vtofd(k) = -krf*v(k) + epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" + ! to update momentum and temp-re; epstofd(k) can be skipped + krf_tofd(k) = krf + enddo +! + end subroutine ugwpv0_tofd1d diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 21b331041..672a2ac81 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -14,7 +14,7 @@ module cires_ugwp use machine, only: kind_phys - use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run @@ -77,7 +77,7 @@ subroutine cires_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if (is_initialized) return if (do_ugwp .or. cdmbgwd(3) > 0.0) then - call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + call cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) else @@ -120,7 +120,7 @@ subroutine cires_ugwp_finalize(errmsg, errflg) if (.not.is_initialized) return - call cires_ugwp_mod_finalize() + call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -293,7 +293,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (cdmbgwd(3) > 0.0) then ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing - call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -365,27 +365,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. endif -#if 0 - !============================================================================= - ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving - ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" - !============================================================================= - ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies - !------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, qgrs(:,:,1), & - del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) - gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked - gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked - gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked -#endif - if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index d7d7da286..887280612 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -1,8 +1,9 @@ [ccpp-table-properties] name = cires_ugwp type = scheme -# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp! - dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90,cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90,cires_vert_wmsdis.F90,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F +# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_initialize.F90 b/physics/cires_ugwp_initialize.F90 index fbcc1d205..e2f7afd7b 100644 --- a/physics/cires_ugwp_initialize.F90 +++ b/physics/cires_ugwp_initialize.F90 @@ -1,41 +1,11 @@ !=============================== ! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) +! initialization of ugwp_common_v0 +! init gw-solvers (1,2) .. no UFS-funds for (3,4) tests ! init gw-source specifications ! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values - - -! module oro_state - -! integer, parameter :: kind_phys=8 -! integer, parameter :: nvaroro=14 -! real (kind=kind_phys), allocatable :: oro_stat(:, :) -! contains - -! subroutine fill_oro_stat(nx, oc, oa4, clx4, theta, gamm, sigma, elvmax, hprime) - -! real (kind=kind_phys),dimension(nx) :: oc, theta, gamm, sigma, elvmax, hprime -! real(kind=kind_phys),dimension(nx,4) :: oa4, clx4 -! integer :: i -! do i=1, nx -! oro_stat(i,1) = hprime(i) -! oro_stat(i,2) = oc(i) -! oro_stat(i,3:6) = oa4(i,1:4) -! oro_stat(i,7:10) = clx4(i,1:4) -! oro_stat(i,11) = theta(i) -! oro_stat(i,12) = gamm(i) -! oro_stat(i,13) = sigma(i) -! oro_stat(i,14) = elvmax(i) -! enddo -! end subroutine fill_oro_stat - -! end module oro_state - - module ugwp_common +!=============================== + module ugwp_common_v0 ! use machine, only: kind_phys use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & @@ -45,7 +15,7 @@ module ugwp_common real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & rdi = 1.0d0/rd, & - gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & + gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & pi2 = pi + pi, omega1 = pi2/86400.0, & omega2 = omega1+omega1, & @@ -53,7 +23,7 @@ module ugwp_common dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) - end module ugwp_common + end module ugwp_common_v0 ! ! !=================================================== @@ -61,7 +31,7 @@ end module ugwp_common !Part-1 init => wave dissipation + RFriction ! !=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) + subroutine init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) implicit none integer :: levs @@ -111,51 +81,20 @@ subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) kvg(k) = kvg(k-1) ktg(k) = ktg(k-1) ! - end subroutine init_global_gwdis -! -! - subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none + end subroutine init_global_gwdis_v0 - integer :: levs - real :: pa_rf, tau_rf - real :: dtp - - real :: pmb(levs) - real :: rfdis(levs), rfdist(levs) - integer :: levs_rf - - real :: krf, krfz - integer :: k -! - rfdis(1:levs) = 1.0 - rfdist(1:levs) = 0.0 - levs_rf = levs - if (tau_rf <= 0.0 .or. pa_rf == 0.0) return - - krf = 1.0/(tau_rf*86400.0) - - do k=levs, 1, -1 - if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" - krfz = krf*log(pa_rf/pmb(k)) - rfdis(k) = 1.0/(1.+krfz*dtp) - rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp - levs_rf = k - endif - enddo - - end subroutine rf_damp_init + ! ======================================================================== ! Part 2 - sources ! wave sources ! ======================================================================== ! -! ugwp_oro_init +! ugwpv0_oro_init ! !========================================================================= - module ugwp_oro_init + module ugwpv0_oro_init - use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi + use ugwp_common_v0, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi implicit none ! @@ -230,7 +169,7 @@ module ugwp_oro_init contains ! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & + subroutine init_oro_gws_v0(nwaves, nazdir, nstoch, effac, & lonr, kxw, cdmbgwd ) ! ! @@ -270,195 +209,10 @@ subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & !.................................................................... ! ! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) - end subroutine init_oro_gws -! - - end module ugwp_oro_init -! ========================================================================= -! -! ugwp_conv_init -! -!========================================================================= - module ugwp_conv_init - - implicit none - real :: eff_con ! scale factors for conv GWs - integer :: nwcon ! number of waves - integer :: nazcon ! number of azimuths - integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud - real :: con_dlength - real :: con_cldf - - real, parameter :: cmin = 5 !2.5 - real, parameter :: cmax = 95. !82.5 - real, parameter :: cmid = 22.5 - real, parameter :: cwid = cmid - real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 - real, parameter :: mstar = 6.28e-3/2. ! 2km - real :: dc - - real, allocatable :: ch_conv(:), spf_conv(:) - real, allocatable :: xaz_conv(:), yaz_conv(:) - contains -! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cgwf) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cgwf(2) - real :: kxw, effac - real :: work1 = 0.5 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - con_dlength = pi2*arad/float(lonr) - con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) -! -! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" -! - if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) - if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) - if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) - if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) -! -! we may use different spectral "shapes" -! for example FVS-93 "Desabeius" -! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail -! - do k = 1,nwaves - chk = cmin + (k-1)*dc - tn4 = (mstar*chk)**4 - ch_conv(k) = chk - spf_conv(k) = bns4*chk/(bns4+tn4) - enddo - - snorm = sum(spf_conv) - spf_conv = spf_conv/snorm*1.5 - - call init_nazdir(nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init -!========================================================================= -! -! ugwp_fjet_init -! -!========================================================================= - - module ugwp_fjet_init - implicit none - real :: eff_fj ! scale factors for conv GWs - integer :: nwfj ! number of waves - integer :: nazfj ! number of azimuths - integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet - - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_fjet(:) , spf_fjet(:) - real, allocatable :: xaz_fjet(:), yaz_fjet(:) - contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwfj = nwaves - nazfj = nazdir - nstfj = nstoch - eff_fj = effac - - if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) - if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) - if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) - if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_fjet(k) = chk - spf_fjet(k) = 1.0 - enddo - call init_nazdir(nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init -! -!========================================================================= -! -! - module ugwp_okw_init -!========================================================================= - implicit none - - real :: eff_okw ! scale factors for conv GWs - integer :: nwokw ! number of waves - integer :: nazokw ! number of azimuths - integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_okwp(:), spf_okwp(:) - real, allocatable :: xaz_okwp(:), yaz_okwp(:) - - contains + end subroutine init_oro_gws_v0 ! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwokw = nwaves - nazokw = nazdir - nstokw = nstoch - eff_okw = effac - - if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) - if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) - if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) - if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_okwp(k) = chk - spf_okwp(k) = 1. - enddo - - call init_nazdir(nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init + end module ugwpv0_oro_init !=============================== end of GW sources ! ! init specific gw-solvers (1,2,3,4) @@ -468,7 +222,7 @@ end module ugwp_okw_init ! Part -3 init wave solvers !=============================== - module ugwp_lsatdis_init + module ugwpv0_lsatdis_init implicit none integer :: nwav, nazd @@ -478,7 +232,7 @@ module ugwp_lsatdis_init ! contains - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_lsatdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) implicit none ! @@ -508,14 +262,14 @@ subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb eff = effac endif ! - end subroutine initsolv_lsatdis + end subroutine initsolv_lsatdis_v0 ! - end module ugwp_lsatdis_init + end module ugwpv0_lsatdis_init ! ! - module ugwp_wmsdis_init + module ugwpv0_wmsdis_init - use ugwp_common, only : pi, pi2 + use ugwp_common_v0, only : pi, pi2 implicit none real, parameter :: maxdudt = 250.e-5 @@ -539,8 +293,6 @@ module ugwp_wmsdis_init real, parameter :: zfluxglob= 3.75e-3 real , parameter :: nslope=1 ! the GW sprctral slope at small-m -! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level -! integer, parameter :: ilaunch=klaunch integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum @@ -563,11 +315,8 @@ module ugwp_wmsdis_init real, allocatable :: zcosang(:), zsinang(:) contains !============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) + subroutine initsolv_wmsdis_v0(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) -! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & -! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) -! implicit none ! !input -control for solvers: @@ -680,25 +429,7 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, print * endif - - end subroutine initsolv_wmsdis + end subroutine initsolv_wmsdis_v0 ! -! make a list of all-initilized parameters needed for "gw_solver_wmsdis" -! - - end module ugwp_wmsdis_init -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis - implicit none - end subroutine init_dspdis - - subroutine init_adodis - implicit none - end subroutine init_adodis - + end module ugwpv0_wmsdis_init diff --git a/physics/cires_ugwp_initialize_v1.F90 b/physics/cires_ugwp_initialize_v1.F90 deleted file mode 100644 index 4258680ea..000000000 --- a/physics/cires_ugwp_initialize_v1.F90 +++ /dev/null @@ -1,805 +0,0 @@ -!=============================== -! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) -! init gw-source specifications -! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values -! -! - - module ugwp_common_v1 -! -! use machine, only : kind_phys -! use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & -! rv => con_rv, cpd => con_cp, fv => con_fvirt,& -! arad => con_rerth - implicit none - - real, parameter :: grav =9.81, cpd = 1004. - real, parameter :: rd = 287.0 , rv =461.5 - real, parameter :: grav2 = grav + grav - real, parameter :: rgrav = 1.0/grav, rgrav2= rgrav*rgrav - - real, parameter :: fv = rv/rd - 1.0 - real, parameter :: rdi = 1.0 / rd, rcpd = 1./cpd, rcpd2 = 0.5/cpd - real, parameter :: gor = grav/rd - real, parameter :: gr2 = grav*gor - real, parameter :: grcp = grav*rcpd, gocp = grcp - real, parameter :: rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - real, parameter :: grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - - real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi, pih = .5*pi - real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 - - real, parameter :: arad = 6370.e3 -! - real, parameter :: bnv2min = (pi2/1800.)*(pi2/1800.) - real, parameter :: bnv2max = (pi2/30.)*(pi2/30.) - - real, parameter :: dw2min=1.0, velmin=sqrt(dw2min), minvel = 0.5 - real, parameter :: omega1 = pi2/86400. - real, parameter :: omega2 = 2.*omega1, omega3 = 3.*omega1 - real, parameter :: hpscale= 7000., rhp=1./hpscale, rhp2=.5*rhp, rh4 = 0.25*rhp - real, parameter :: mkzmin = pi2/80.0e3, mkz2min = mkzmin*mkzmin - real, parameter :: mkzmax = pi2/500., mkz2max = mkzmax*mkzmax - real, parameter :: cdmin = 2.e-2/mkzmax - end module ugwp_common_v1 -! -! -!=================================================== -! -!Part-1 init => wave dissipation + RFriction -! -!=================================================== - subroutine init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - pa_rf, tau_rf, me, master) - - - implicit none - integer , intent(in) :: me, master - integer , intent(in) :: levs - real, intent(in) :: con_pi, pa_rf, tau_rf - real, intent(in) :: zkm(levs), pmb(levs) ! in km-Pa - real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion -! -!locals + data -! - integer :: k - real, parameter :: vusurf = 2.e-5 - real, parameter :: musurf = vusurf/1.95 - real, parameter :: hpmol = 8.5 -! - real, parameter :: kzmin = 0.1 - real, parameter :: kturbo = 100. - real, parameter :: zturbo = 130. - real, parameter :: zturw = 30. - real, parameter :: inv_pra = 3. !kt/kv =inv_pr -! - real, parameter :: alpha = 1./86400./15. ! height variable see Zhu-1993 from 60-days => 6 days - real :: pa_alp = 750. ! super-RF parameters - real :: tau_alp = 10. ! days (750 Pa /10days) -! - real, parameter :: kdrag = 1./86400./30. !parametrization for WAM for FV3GFS SuperRF - real, parameter :: zdrag = 100. - real, parameter :: zgrow = 50. -! - real :: vumol, mumol, keddy, ion_drag - real :: rf_fv3, rtau_fv3, ptop, pih_dlog -! - real :: ae1 ,ae2 - real :: pih - - pih = 0.5*con_pi - - pa_alp = pa_rf - tau_alp = tau_rf - - ptop = pmb(levs) - rtau_fv3 = 1./86400./tau_alp - pih_dlog = pih/log(pa_alp/ptop) - - do k=1, levs - ae1 = -zkm(k)/hpmol - vumol = vusurf*exp(ae1) - mumol = musurf*exp(ae1) - ae2 = -((zkm(k)-zturbo) /zturw)**2 - keddy = kturbo*exp(ae2) - - kvg(k) = vumol + keddy - ktg(k) = mumol + keddy*inv_pra - - krad(k) = alpha -! - ion_drag = kdrag -! - kion(k) = ion_drag! -! add Rayleigh_Super of FV3 for pmb < pa_alp -! - if (pmb(k) .le. pa_alp) then - rf_fv3=rtau_fv3*sin(pih_dlog*log(pa_alp/pmb(k)))**2 - krad(k) = krad(k) + rf_fv3 - kion(k) = kion(k) + rf_fv3 - - endif - -! write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) - enddo - - k= levs+1 - kion(k) = kion(k-1) - krad(k) = krad(k-1) - kvg(k) = kvg(k-1) - ktg(k) = ktg(k-1) - if (me == master) then - write(6, * ) ' zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k) ' - do k=1, levs, 1 - write(6,132) zkm(k), kvg(k), kvg(k)*(6.28/5000.)**2, kion(k), pmb(k) - enddo - endif -! - 132 format( 2x, F8.3,' dis-scales:', 4(2x, E10.3)) - - end subroutine init_global_gwdis_v1 -! -! - subroutine rf_damp_init_v1(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none - - integer :: levs - real :: pa_rf, tau_rf - real :: dtp - - real :: pmb(levs) - real :: rfdis(levs), rfdist(levs) - integer :: levs_rf - - real :: krf, krfz - integer :: k -! - rfdis(1:levs) = 1.0 - rfdist(1:levs) = 0.0 - levs_rf = levs - if (tau_rf <= 0.0 .or. pa_rf == 0.0) return - - krf = 1.0/(tau_rf*86400.0) - - do k=levs, 1, -1 - if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" - krfz = krf*log(pa_rf/pmb(k)) - rfdis(k) = 1.0/(1.+krfz*dtp) - rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp - levs_rf = k - endif - enddo - - end subroutine rf_damp_init_v1 -! ======================================================================== -! Part 2 - sources -! wave sources -! ======================================================================== -! -! ugwp_oro_init_v1 -! -!========================================================================= - module ugwp_oro_init_v1 - - use ugwp_common_v1, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi - use ugwp_common_v1, only : mkzmin, mkz2min - implicit none -! -! constants and "crirtical" values to run oro-mtb_gw physics -! -! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' -! -! - real, parameter :: hncrit=9000. ! max value in meters for elvmax - real, parameter :: hminmt=50. ! min mtn height (*j*) - real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor -! -! - real, parameter :: minwnd=1.0 ! min wind component (*j*) - real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa - real, parameter :: hpmax=2400.0, hpmin=25.0 - - character(len=8) :: strver = 'gfs_2018' - character(len=8) :: strbase = 'gfs_2018' - real, parameter :: rimin=-10., ric=0.25 - -! - real, parameter :: efmin=0.5, efmax=10.0 - - - real, parameter :: sigma_std=1./100., gamm_std=1.0 - - real, parameter :: frmax=10., frc =1.0, frmin =0.01 -! - - real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 - real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 -! - real, parameter :: rlolev=50000.0 -! - - -! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt - - - - real, parameter :: kxoro=6.28e-3/200. ! - real, parameter :: coro = 0.0 - integer, parameter :: nridge=2 - - real :: cdmb ! scale factors for mtb - real :: cleff ! scale factors for orogw - integer :: nworo ! number of waves - integer :: nazoro ! number of azimuths - integer :: nstoro ! flag for stochastic launch above SG-peak - - integer, parameter :: mdir = 8 - real, parameter :: fdir=.5*mdir/pi - - integer nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ - save nwdir - - real, parameter :: odmin = 0.1, odmax = 10.0 -!------------------------------------------------------------------------------ -! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS -!------------------------------------------------------------------------------ - - integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl - real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters - real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] - real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km -!------------------------------------------------------------------------------ -! - real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm - real, parameter :: fcrit_gfs = 0.7 - real, parameter :: fcrit_mtb = 0.7 - - real, parameter :: zbr_pi = (1.0/2.0)*pi - real, parameter :: zbr_ifs = 0.5*pi - - contains -! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cdmbgwd ) -! -! - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) - ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 - real :: cdmbX - real :: kxw - real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now -!-----------------------------! GFS-setup for cdmb & cleff -! cdmb = 4.0 * (192.0/IMX) -! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) -! - real, parameter :: lonr_refmb = 4.0 * 192.0 - real, parameter :: lonr_refgw = 192.0 - -! copy to "ugwp_oro_init_v1" => nwaves, nazdir, nstoch - - nworo = nwaves - nazoro = nazdir - nstoro = nstoch - - cdmbX = lonr_refmb/float(lonr) - cdmb = cdmbX - if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) - - cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac - -!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac - - if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) -! -!.................................................................... -! higher res => smaller h' ..&.. higher kx -! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) -!.................................................................... -! -! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) - end subroutine init_oro_gws -! - - end module ugwp_oro_init_v1 -! ========================================================================= -! -! ugwp_conv_init_v1 -! -!========================================================================= - module ugwp_conv_init_v1 - - implicit none - real :: eff_con ! scale factors for conv GWs - integer :: nwcon ! number of waves - integer :: nazcon ! number of azimuths - integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud - real :: con_dlength - real :: con_cldf - - real, parameter :: cmin = 5 !2.5 - real, parameter :: cmax = 95. !82.5 - real, parameter :: cmid = 22.5 - real, parameter :: cwid = cmid - real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 - real, parameter :: mstar = 6.28e-3/2. ! 2km - real :: dc - - real, allocatable :: ch_conv(:), spf_conv(:) - real, allocatable :: xaz_conv(:), yaz_conv(:) - contains -! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - con_pi, arad, lonr, kxw, cgwf) - - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi, arad - real :: cgwf(2) - real :: kxw, effac - real :: work1 = 0.5 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - con_dlength = 2.0*con_pi*arad/float(lonr) - con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) -! -! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" -! - if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) - if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) - if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) - if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) -! -! we may use different spectral "shapes" -! for example FVS-93 "Desabeius" -! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail -! - do k = 1,nwaves - chk = cmin + (k-1)*dc - tn4 = (mstar*chk)**4 - ch_conv(k) = chk - spf_conv(k) = bns4*chk/(bns4+tn4) - enddo - - snorm = sum(spf_conv) - spf_conv = spf_conv/snorm*1.5 - - call init_nazdir(con_pi, nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init_v1 -!========================================================================= -! -! ugwp_fjet_init_v1 -! -!========================================================================= - - module ugwp_fjet_init_v1 - implicit none - real :: eff_fj ! scale factors for conv GWs - integer :: nwfj ! number of waves - integer :: nazfj ! number of azimuths - integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet - - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_fjet(:) , spf_fjet(:) - real, allocatable :: xaz_fjet(:), yaz_fjet(:) - contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - real :: kxw, effac , chk - - integer :: k - - nwfj = nwaves - nazfj = nazdir - nstfj = nstoch - eff_fj = effac - - if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) - if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) - if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) - if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_fjet(k) = chk - spf_fjet(k) = 1.0 - enddo - call init_nazdir(con_pi, nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init_v1 -! -!========================================================================= -! -! - module ugwp_okw_init_v1 -!========================================================================= - implicit none - - real :: eff_okw ! scale factors for conv GWs - integer :: nwokw ! number of waves - integer :: nazokw ! number of azimuths - integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_okwp(:), spf_okwp(:) - real, allocatable :: xaz_okwp(:), yaz_okwp(:) - - contains -! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, & - con_pi, lonr, kxw) - - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: con_pi - real :: kxw, effac , chk - - integer :: k - - nwokw = nwaves - nazokw = nazdir - nstokw = nstoch - eff_okw = effac - - if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) - if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) - if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) - if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_okwp(k) = chk - spf_okwp(k) = 1. - enddo - - call init_nazdir(con_pi, nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init_v1 - -!=============================== end of GW sources -! -! init specific gw-solvers (1,2,3,4) -! - -!=============================== -! Part -3 init wave solvers -!=============================== - - module ugwp_lsatdis_init_v1 - implicit none - - integer :: nwav, nazd - integer :: nst - real :: eff - integer, parameter :: incdim = 4, iazdim = 4 -! - contains - - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - - implicit none -! - integer :: me, master - integer :: nwaves, nazdir - integer :: nstoch - real :: effac - logical :: do_physb - real :: kxw -! -!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces -! are not actibve -! - integer :: inc, jk, jl, iazi, i, j, k - - if( nwaves == 0 .or. nstoch == 1 ) then -! redefine from the default - nwav = incdim - nazd = iazdim - nst = 0 - eff = 1.0 - else -! from input_nml multi-wave spectra - nwav = nwaves - nazd = nazdir - nst = nstoch - eff = effac - endif -! - end subroutine initsolv_lsatdis -! - end module ugwp_lsatdis_init_v1 -! -! - module ugwp_wmsdis_init_v1 - - use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4, omega2 - use ugwp_common_v1, only : bnv2max, bnv2min, minvel - use ugwp_common_v1, only : mkzmin, mkz2min, mkzmax, mkz2max, cdmin - implicit none - - real, parameter :: maxdudt = 250.e-5, maxdtdt=15.e-2 - real, parameter :: dked_min =0.01, dked_max=250.0 - - real, parameter :: gptwo=2.0 - - real , parameter :: bnfix = pi2/300., bnfix2= bnfix * bnfix - real , parameter :: bnfix4 = bnfix2 * bnfix2 - real , parameter :: bnfix3 = bnfix2 * bnfix -! -! make parameter list that will be passed to SOLVER -! -! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level -! integer, parameter :: ilaunch=klaunch - - integer , parameter :: iazidim=4 ! number of azimuths - integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum - real , parameter :: ucrit=cdmin - - real , parameter :: zcimin = 2.5 - real , parameter :: zcimax = 125.0 - real , parameter :: zgam = 0.25 -! -! Verical spectra -! - real , parameter :: pind_wd = 5./3. - real , parameter :: sind_kz = 1. - real , parameter :: tind_kz = 3. - real , parameter :: stind_kz = sind_kz + tind_kz -! -! from kmob_ugwp namelist -! - real :: nslope ! the GW sprctral slope at small-m - real :: lzstar - real :: lzmin - real :: lzmax - real :: lhmet - real :: tamp_mpa !amplitude for GEOS-5/MERRA-2 - real :: tau_min ! min of GW MF 0.25 mPa - integer :: ilaunch - real :: gw_eff - - real :: v_kxw, rv_kxw, v_kxw2 - - - -!=========================================================================== - integer :: nwav, nazd, nst - real :: eff - - real :: zaz_fct, zms - real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) - real, allocatable :: zcosang(:), zsinang(:) - real, allocatable :: lzmet(:), czmet(:), mkzmet(:), dczmet(:), dmkz(:) - -! -! GW-eddy constants for wave-mode dissipation by background and stability of -! "final" flow after application of GW-effects -! - real, parameter :: iPr_pt = 0.5 - real, parameter :: lturb = 30., sc2 = lturb*lturb ! stable on 80-km TL lmix ~ 500 met. - real, parameter :: ulturb=150., sc2u = ulturb* ulturb ! unstable - real, parameter :: ric =0.25 - real, parameter :: rimin = -10., prmin = 0.25 - real, parameter :: prmax = 4.0 -! - contains -!============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - -! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & -! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) -! - implicit none -! -!input -control for solvers: -! nwaves, nazdir, nstoch, effac, do_physb, kxw -! -! - integer :: me, master, nwaves, nazdir, nstoch - real :: effac, kxw - logical :: do_physb - real :: dlzmet -! -!locals -! - integer :: inc, jk, jl, iazi -! - real :: zang, zang1, znorm - real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp - real :: fpc, fpc_dc - real :: ae1,ae2 - if( nwaves == 0) then -! -! redefine from the deafault -! - nwav = incdim - nazd = iazidim - nst = 0 - eff = 1.0 - gw_eff = eff - else -! -! from input.nml -! - nwav = nwaves - nazd = nazdir - nst = nstoch - gw_eff = effac - endif - - - v_kxw = pi2/lhmet ; v_kxw2 = v_kxw*v_kxw - rv_kxw = 1./v_kxw - - allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) - allocate ( zcosang(nazd), zsinang(nazd) ) - allocate (lzmet(nwav), czmet(nwav), mkzmet(nwav), dczmet(nwav), dmkz(nwav) ) - - if (me == master) then - print *, 'ugwp_v1: init_gw_wmsdis_control ' -! - print *, 'ugwp_v1: WMS_DIS launch layer ', ilaunch - print *, 'ugwp_v1: WMS_DIS tot_mflux in mpa', tamp_mpa*1000. - print *, 'ugwp_v1: WMS_DIS lhmet in km ' , lhmet*1.e-3 - endif - - zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. - -! -! set up azimuth directions and some trig factors -! -! - zang = pi2 / float(nazd) - -! get normalization factor to ensure that the same amount of momentum -! flux is directed (n,s,e,w) no mater how many azimuths are selected. -! - znorm = 0.0 - do iazi=1, nazd - zang1 = (iazi-1)*zang - zcosang(iazi) = cos(zang1) - zsinang(iazi) = sin(zang1) - znorm = znorm + abs(zcosang(iazi)) - enddo -! zaz_fct = 1.0 - zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums - -! define coordinate transform for "Ch" ....x = 1/c stretching transform -! ----------------------------------------------- -! -! x=1/Cphase transform -! see eq. 28-30 Scinocca 2003. x = 1/c stretching transform -! - zxmax = 1.0 / zcimin - zxmin = 1.0 / zcimax - zxran = zxmax - zxmin - zdx = zxran / real(nwav-1) ! dkz -! - ae1=zxran/zgam - zx1 = zxran/(exp(ae1)-1.0 ) ! zgam =1./4. - zx2 = zxmin - zx1 - -! -! computations for zci =1/zx, stretching "accuracy" is not "accurate" spectra transform -! it represents additional "empirical" redistribution of "spectral" mode in C-space -! - zms = pi2 / lzstar - - do inc=1, nwav - ztx = real(inc-1)*zdx+zxmin - ae1 = (ztx-zxmin)/zgam - zx = zx1*exp(ae1)+zx2 !eq.(29-30),Scinocca-2003 - zci(inc) = 1.0 /zx ! - zdci(inc) = zci(inc)**2*(zx1/zgam)*exp(ae1)*zdx ! - zci4(inc) = (zms*zci(inc))**4 - zci2(inc) = (zms*zci(inc))**2 - zci3(inc) = (zms*zci(inc))**3 - enddo -! -! -! alternatuve lzmax-lzmin -! -! - dlzmet = (lzmax-lzmin)/ real(nwav-1) - do inc=1, nwav - lzmet(inc) = lzmin + (inc-1)*dlzmet - mkzmet(inc) = pi2/lzmet(inc) - zci(inc) =lzmet(inc)/(pi2/bnfix) - zci4(inc) = (zms*zci(inc))**4 - zci2(inc) = (zms*zci(inc))**2 - zci3(inc) = (zms*zci(inc))**3 - - enddo - - zdx = (zci(nwav)-zci(1))/ real(nwav-1) - - - if (me == master) then - print * - print *, 'ugwp_v0: zcimin=' , zcimin - print *, 'ugwp_v0: zcimax=' , zcimax - print *, 'ugwp_v0: zgam= ', zgam - print * - -! print *, ' ugwp_v1 nslope=', nslope - print * - print *, 'ugwp_v1: zcimin/zci=' , maxval(zci) - print *, 'ugwp_v1: zcimax/zci=' , minval(zci) - print *, 'ugwp_v1: cd_crit=', ucrit - print *, 'ugwp_v1: launch_level', ilaunch - print *, ' ugwp_v1 lzstar=', lzstar - print *, ' ugwp_v1 nslope=', nslope - - print * - do inc=1, nwav - zdci(inc) = zdx - if (nslope == 1) fpc = bnfix4*zci(inc)/ (bnfix4+zci4(inc)) - if (nslope == 0) fpc = bnfix3*zci(inc)/ (bnfix3+zci3(inc)) - fpc_dc = fpc * zdci(inc) - write(6,111) inc, zci(inc), zdci(inc),ucrit, fpc, fpc_dc, 6.28e-3/bnfix*zci(inc) - enddo - endif - 111 format( 'wms-zci', i4, 7 (3x, F8.3)) - - end subroutine initsolv_wmsdis -! -! make a list of all-initilized parameters needed for "gw_solver_wmsdis" -! - - end module ugwp_wmsdis_init_v1 -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis_v1 - implicit none - end subroutine init_dspdis_v1 - - subroutine init_adodis_v1 - implicit none - end subroutine init_adodis_v1 - diff --git a/physics/cires_ugwp_module.F90 b/physics/cires_ugwp_module.F90 index 51c297237..620386ead 100644 --- a/physics/cires_ugwp_module.F90 +++ b/physics/cires_ugwp_module.F90 @@ -1,17 +1,12 @@ ! -module cires_ugwp_module +module cires_ugwpv0_module ! ! driver is called after pbl & before chem-parameterizations ! -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! + implicit none logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver @@ -54,7 +49,7 @@ module cires_ugwp_module data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] - integer :: knob_ugwp_version = 0 + integer :: knob_ugwp_version = 0 ! version control had sense under IPD in CCPP=> to SUITES integer :: launch_level = 55 ! namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & @@ -106,16 +101,14 @@ module cires_ugwp_module ! init of cires_ugwp (_init) called from GFS_driver.F90 ! ! ----------------------------------------------------------------------- - subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + subroutine cires_ugwpv0_mod_init (me, master, nlunit, input_nml_file, logunit, & fn_nml, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & pa_rf_in, tau_rf_in) - use ugwp_oro_init, only : init_oro_gws - use ugwp_conv_init, only : init_conv_gws - use ugwp_fjet_init, only : init_fjet_gws - use ugwp_okw_init, only : init_okw_gws - use ugwp_wmsdis_init, only : initsolv_wmsdis, ilaunch - use ugwp_lsatdis_init, only : initsolv_lsatdis + use ugwpv0_oro_init, only : init_oro_gws_v0 + use ugwpv0_wmsdis_init, only : initsolv_wmsdis_v0, ilaunch + use ugwpv0_lsatdis_init, only : initsolv_lsatdis_v0 + implicit none integer, intent (in) :: me @@ -132,7 +125,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes real, intent (in) :: pa_rf_in, tau_rf_in -! integer, parameter :: logunit = 6 integer :: ios logical :: exists real :: dxsg @@ -155,8 +147,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & read (nlunit, nml = cires_ugwp_nml) close (nlunit) #endif - - ! ilaunch = launch_level @@ -173,13 +163,6 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! effective kxw - resolution-aware ! dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh -! -! kxw = pi2/dxsg -! -! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff -! - -! allocate(fcor(latr), fcor2(latr) ) ! allocate( kvg(levs+1), ktg(levs+1) ) allocate( krad(levs+1), kion(levs+1) ) @@ -195,50 +178,22 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! ! Part-1 :init_global_gwdis ! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) - call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) + call init_global_gwdis_v0(levs, zkm, pmb, kvg, ktg, krad, kion) + ! -! Part-2 :init_SOURCES_gws +! Part-2 :init_SOURCES_gws -- only orowaves, but ugwp-v0 is based on gwdps.f of EMC ! ! ! call init-solver for "stationary" multi-wave spectra and sub-grid oro ! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & + call init_oro_gws_v0( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) ! ! call init-sources for "non-sationary" multi-wave spectra ! do_physb_gwsrcs=.true. - IF (do_physb_gwsrcs) THEN - - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' - if (knob_ugwp_wvspec(4) > 0) then -! okw - call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' - endif - - if (knob_ugwp_wvspec(3) > 0) then -! fronts - call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' - endif - - if (knob_ugwp_wvspec(2) > 0) then -! conv - call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) - if (me == master) & - print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) - - endif - - ENDIF !IF (do_physb_gwsrcs) - !====================== ! Part-3 :init_SOLVERS ! ===================== @@ -247,428 +202,40 @@ subroutine cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & ! if (knob_ugwp_solver==1) then ! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_lsatdis_v0(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) endif if (knob_ugwp_solver==2) then - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & + call initsolv_wmsdis_v0(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) endif -! -! other solvers not yet tested for fv3gfs -! -!< if (knob_ugwp_solver==3) call init_dspdis -!< if (knob_ugwp_solver==4) call init_adodis -! + !====================== module_is_initialized = .true. - if (me == master) print *, ' VAY-ugwp is initialized ', module_is_initialized - - end subroutine cires_ugwp_mod_init - -! ----------------------------------------------------------------------- -! -! driver of cires_ugwp (_driver) -! called from GFS_physics_driver.F90 -! -! ----------------------------------------------------------------------- -! call cires_ugwp_driver & -! (im, levs, dtp, kdt, me, lprnt, Model%lonr, & -! Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & -! Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & -! Statein, delp_gws, Oro_stat, & -! dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & -! Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & -! Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & -! Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & -! Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & -! Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & -! Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & -! Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & -! Diag%du3dt_ogw, Diag%du3dt_tms ) - - subroutine cires_ugwp_driver & - (im, levs, dtp, kdt, me, lprnt, lonr, & - pa_rf, tau_rf, cdmbgwd, xlat, xlatd, sinlat, coslat, & - ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & - delp, orostat, kpbl, & - dusfc, dvsfc, dudt, dvdt, dtdt, kdis, & - axtot, axo, axc, axf, aytot, ayo, ayc, ayf, & - eps_tot, ekdis, trig_okw, trig_fgf, & - dcheat, precip, cld_klevs, zmtb, scheat, dlength, cldf, & - taus_sso, taus_ogw, tauf_ogw, tauf_ngw, & - ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb, ugw_axlwb, ugw_axtms ) - -! - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd - use ugwp_common, only: omega2 -! -! - use ugwp_okw_init, only : & - eff_okw, nstokw, nwokw, ch_okwp, nazokw, spf_okwp, xaz_okwp, yaz_okwp - use ugwp_conv_init, only : & - eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv - use ugwp_fjet_init, only : & - eff_fj, nstfj, nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet - -! - implicit none -! - - logical :: lprnt - integer :: me, im, levs, kdt, lonr - real(kind_phys) :: dtp - real(kind_phys) :: pa_rf, tau_rf - real(kind_phys) :: cdmbgwd(2) - - integer, intent(in) :: kpbl(im) - real(kind_phys) :: hpbl(im) - real(kind_phys), intent(in) :: orostat(im, 14) - real(kind_phys), intent(in), dimension(im,levs) :: ugrs, vgrs, & - tgrs, qgrs, prsi, prsl, prslk, phii, phil, delp -! - real(kind_phys), dimension(im) :: xlat, xlatd, sinlat, coslat - real(kind_phys), dimension(im, levs) :: trig_okw, trig_fgf - real(kind_phys), dimension(im) :: precip ! precip-n rates and - integer , dimension(im, 3) :: cld_klevs ! indices fo cloud top/bot/? - real(kind_phys), dimension(im, levs) :: dcheat, scheat ! deep and shal conv heat tend. - - - real(kind_phys), dimension(im) :: dlength ! tail-grid box scale in meters - real(kind_phys), dimension(im) :: cldf ! "bizzard" old cgwd-tuning knobs dimensionless -!=================== -! tendency + kdis -!=================== - real(kind_phys), dimension(im, levs) :: dudt, dvdt, dtdt, kdis - real(kind_phys), dimension(im, levs) :: axtot, axo, axc, axf - real(kind_phys), dimension(im, levs) :: aytot, ayo, ayc, ayf - real(kind_phys), dimension(im, levs) :: eps_tot, ekdis - -! - real(kind_phys), dimension(im, levs) :: eds_o, kdis_o - real(kind_phys), dimension(im, levs) :: eds_c, kdis_c - real(kind_phys), dimension(im, levs) :: eds_f, kdis_f - real(kind_phys), dimension(im, levs) :: ax_rf, ay_rf, eps_rf -! -!================================================================================== -! diagnostics for OGW & NGW + SSO effects axmtb, axlwb, axtms -!================================================================================== - real(kind_phys), dimension(im) :: dusfc, dvsfc - real(kind_phys), dimension(im) :: taus_sso, taus_ogw, tauf_ogw, tauf_ngw - real(kind_phys), dimension(im) :: ugw_zmtb, ugw_zlwb, ugw_zogw - real(kind_phys), dimension(im, levs) :: ugw_axmtb,ugw_axlwb, ugw_axtms - real(kind_phys), dimension(im, levs) :: tauz_ogw, tauz_ngw, wtauz - -! -! knob_ugwp_source=[ 1, 1, 1, 0 ] -! oro conv nst imbal-okw -! locals -! - integer :: i, j, k, istype, ido -! -! internal diagnostics for oro-waves, lee waves, and mtb : -! - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw ! GW-launch levels in "meters" -! - real(kind_phys), dimension(im) :: fcor, c2f2 -! -! three sources with different: a) spectra-content/azimuth; b) efficiency ;c) spectral shape -! - real(kind_phys), dimension(im) :: taub_con, taub_fj, taub_okw - integer , dimension(im) :: klev_okw, klev_fj, klev_con - integer , dimension(im) :: if_okw, if_con, if_fj - integer :: nf_okw, nf_con, nf_fj -! - dudt = 0. - dvdt = 0. - dtdt = 0. - kdis = 0. - axo = 0. ; axc = 0. ; axf = 0. - ayo = 0. ; ayc = 0. ; ayf = 0. - eds_o = 0. ; kdis_o = 0. ; eds_f = 0. ; kdis_f = 0. ; eds_c = 0. ; kdis_c = 0. - ax_rf = 0. ; ay_rf = 0. ; eps_rf = 0 - - hpbl(:) = 2000. ! hpbl (1:im) = phil(1:im, kpbl(1:im)) -! - - do i=1, im - fcor(i) = omega2*sinlat(i) - c2f2(i) = fcor(i)*fcor(i)/(kxw*kxw) - enddo - -! i=im -! print *, i, fcor(i), 6.28e-3/kxw, sqrt(c2f2(i)) -! print *, maxval(statein%prsl/statein%tgrs)/287. , ' density ' - -! -! -! What can be computed for ALL types of GWs? => -! "Br-Vi frequency"with "limits" in case of "conv-unstable" layers -! Background dissipation: Molecular + Eddy -! Wind projections may differ from GW-sources/propagation azimuths -! - do istype=1, size(knob_ugwp_source) - - ido = knob_ugwp_source(istype) ! 0 or 1 off or active - - ugwp_azdir = knob_ugwp_azdir(istype) - ugwp_stoch = knob_ugwp_stoch(istype) - ugwp_nws = knob_ugwp_wvspec(istype) - ugwp_effac = knob_ugwp_effac(istype) - -! -! oro-gw effects -! - if (ido == 1 .and. istype ==1 ) then -! -! 1. solve for OGW effects on the mean flow -! 2. all parts of ORO effexra inside: MTB TOFD LeeWB OGW-drag -! - call ugwp_oro(im, levs, dtp, kdt, me, lprnt, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - orostat, hpbl, axo, ayo, eds_o, kdis_o, & - dusfc, dvsfc, dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, & - dusfc_lwb, dvsfc_lwb, zmtb, zlwb, zogw,tauf_ogw,tauz_ogw,& - ugw_axmtb,ugw_axlwb, ugw_axtms) -! -! taus_sso, taus_ogw, tauz_ogw, tauz_ngw, tauf_ogw, tauf_ngw, & -! ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb,ugw_axlwb, ugw_axtms -! collect column-integrated "dusfc, dvsfc" only for oro-waves -! - taus_sso = dusfc_mb + dusfc_lwb + dusfc_ogw - taus_ogw = dusfc_ogw - ugw_zmtb = zmtb - ugw_zlwb = zlwb - ugw_zogw = zogw -! tauz_ogw/tauf_ogw => output -! ugwp_azdir, ugwp_stoch, ugwp_nws ..... "multi-wave + stochastic" -! -! stationary gw-mode ch=0, with "gw_solver_linsat" -! compute column-integrated "dusfc, dvsfc" only for oro-waves -! - dudt = dudt + axo * ugwp_effac - dvdt = dvdt + ayo * ugwp_effac - dtdt = dtdt + eds_o * ugwp_effac - kdis = kdis + kdis_o* ugwp_effac -! print *, ' ido istype ORO=1 ', ido, istype, ' ugwp_oro as a solver ' - endif - - if (ido == 1 .and. istype ==2 ) then -! -! convective gw effects -! -! 1. specify spectra + forcing nstcon, nwcon, ch_conv, nazcon, spf_conv -! - call get_spectra_tau_convgw & - (nwcon, im, levs, dcheat, scheat, precip, cld_klevs, & - xlatd, sinlat, coslat, taub_con, klev_con, if_con, nf_con) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_con > 0) then - - klev_con(:) = 52 ! ~5 km -! -!eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv, & - fcor, c2f2, ugrs, vgrs, tgrs, qgrs, prsi, delp, & - prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) - - - if (knob_ugwp_solver == 2) then -! print *, ' before CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) -! print *, ' after ido istype CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - endif - - dudt = dudt + axc * ugwp_effac - dvdt = dvdt + ayc * ugwp_effac - dtdt = dtdt + eds_c * ugwp_effac - kdis = kdis + kdis_c * ugwp_effac - - tauz_ngw = wtauz - - endif - - endif - - if (ido == 1 .and. istype ==3 ) then -! -! nonstationary gw effects -! -! 1. specify spectra + forcing -! - call get_spectra_tau_nstgw (nwfj, im, levs, & - trig_fgf, xlatd, sinlat, coslat, taub_fj, klev_fj, if_fj, nf_fj) -! -! 2. solve for GW effects on the mean flow -! - print *, ' tau_nstgw nf_fj-GW triggers ', nf_fj, ' ugwp_solver = ', knob_ugwp_solver - if ( nf_fj > 0) then - - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - print *, ' ido istype for FJ 1-4 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - - endif - endif -! print *, ' ido istype for okw 1-4 ', ido, istype - if (ido == 1 .and. istype == 4 ) then -! -! nonstationary gw effects due to both "convection +fronts/jets " = imbalance of rs-flow -! -! 1. specify spectra + forcing -! - call get_spectra_tau_okw (nwokw, im, levs,& - trig_okw, xlatd, sinlat, coslat, taub_okw, klev_okw, if_okw, nf_okw) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_okw > 0) then -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - endif - endif -! -! broad gw-spectra -! - 356 continue - enddo -! -! gw-diag only -! - axtot = dudt - aytot = dvdt - eps_tot = dtdt - -! -! optional rf-damping -! - if (do_rfdamp) then -! -! - call rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, ugrs, vgrs, ax_rf, ay_rf, eps_rf) -! -! gw-diag only + rf-damping ..... now orchestrate it with FV3-dycore RF-damping -! - do k=levs_rf, levs - - dudt(:,k) = dudt(:,k) + ax_rf(:,k) - dvdt(:,k) = dvdt(:,k) + ay_rf(:,k) - dtdt(:,k) = dtdt(:,k) + eps_rf(:,k) - - enddo - - endif -!================================================================================ -! To update U-V-T STATE by [dudt dvdt dtdt kdis+rf] => Solve 3-diag VD-equation -!================================================================================ -! to do for fv3wam=> -! joint eddy+molecular viscosity/conductivity/diffusion -! requires "dqdt" + dudt_vis, dvdt_vis. dtdt_cond - -! print *, ' cires_ugwp_driver +++++++++++++++++ ' -! - end subroutine cires_ugwp_driver - - -!============================================= - - - subroutine cires_ugwp_advance -!----------------------------------------------------------------------- -! -! options for the day-to-day variable sources/spectra + diagnostics -! for stochastic "triggers" -! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields -! or use for stochastic GWP-sources "memory" -!----------------------------------------------------------------------- - implicit none -! -! update sources -! a) physics-based triggers for multi-wave -! b) stochastic-based spectra and amplitudes -! c) use "memory" on GW-spectra from previous time-step -! d) update "background" GW dissipation as needed -! - end subroutine cires_ugwp_advance - + end subroutine cires_ugwpv0_mod_init ! ! ----------------------------------------------------------------------- ! finalize of cires_ugwp (_finalize) ! ----------------------------------------------------------------------- - - subroutine cires_ugwp_mod_finalize + subroutine cires_ugwpv0_mod_finalize ! ! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" ! before "end" of the FV3GFS ! implicit none ! -! deallocate arrays employed in: -! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init +! deallocate arrays employed in V0 ! deallocate( kvg, ktg ) deallocate( krad, kion ) deallocate( zkm, pmb ) deallocate( rfdis, rfdist) - end subroutine cires_ugwp_mod_finalize + end subroutine cires_ugwpv0_mod_finalize ! - end module cires_ugwp_module + end module cires_ugwpv0_module diff --git a/physics/cires_ugwp_module_v1.F90 b/physics/cires_ugwp_module_v1.F90 deleted file mode 100644 index fd41d8175..000000000 --- a/physics/cires_ugwp_module_v1.F90 +++ /dev/null @@ -1,672 +0,0 @@ - -module cires_ugwp_module_v1 - -! -! driver is called after pbl & before chem-parameterizations -! it uses ugwp_common (like phys_cons) and some module-param od solvers/sources init-modules -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! - use ugwp_common_v1, only : arad, pi, pi2, hpscale, rhp, rhp2, rh4 - implicit none - logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction - character(len=8) :: strsolver='pss-1986' - logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources - logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver - integer, parameter :: idebug_gwrms=1 ! control for diag computaions pw wind-temp GW-rms and MF fluxs - logical, parameter :: do_adjoro = .false. - real, parameter :: max_kdis = 250. ! 400 m2/s - real, parameter :: max_axyz = 250.e-5 ! 400 m/s/day - real, parameter :: max_eps = max_kdis*4.e-7 ! ~16 K/day max_kdis*BN2/cp - real, parameter :: maxdudt = max_axyz - real, parameter :: maxdtdt = max_eps - real, parameter :: dked_min = 0.01 - real, parameter :: dked_max = max_kdis - - - real, parameter :: hps = hpscale - real, parameter :: hpskm = hps/1000. -! - - real, parameter :: ricrit = 0.25 - real, parameter :: frcrit = 0.50 - real, parameter :: linsat = 1.00 - real, parameter :: linsat2 = linsat*linsat -! -! integer :: curday_ugwp ! yyyymmdd 20150101 -! integer :: ddd_ugwp ! ddd of year from 1-366 - - integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) - integer, dimension(4) :: knob_ugwp_source=(/1,0,1,0/) ! [1,0,1,1] - (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_wvspec=(/1,32,32,32/) ! number of waves for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_azdir=(/2,4,4,4/) ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_stoch=(/0,0,0,0/) ! 0 - deterministic ; 1 - stochastic - real, dimension(4) :: knob_ugwp_effac=(/1.,1.,1.,1./) ! efficiency factors for- (oro, fronts, conv, imbf-owp] - - integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag - integer :: knob_ugwp_doheat=1 ! 1 -gwheat - integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing - integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw - integer :: knob_ugwp_nslope = 1 ! spectral"growth" S-slope of GW-energy spectra mkz^S - - real :: knob_ugwp_palaunch = 500.e2 ! fixed pressure layer in Pa for "launch" of NGWs - real :: knob_ugwp_lzmax = 12.5e3 ! 12.5 km max-VERT-WL of GW-spectra - real :: knob_ugwp_lzstar = 2.0e3 ! UTLS mstar = 6.28/lzstar 2-2.5 km - real :: knob_ugwp_lzmin = 1.5e3 ! 1.5 km min-VERT-WL of GW-spectra - real :: knob_ugwp_taumin = 0.25e-3 - real :: knob_ugwp_tauamp = 7.75e-3 ! range from 30.e-3 to 3.e-3 ( space-borne values) - real :: knob_ugwp_lhmet = 200.e3 ! 200 km -! - real :: kxw = pi2/200.e3 ! single horizontal wavenumber of ugwp schemes -! -! tune-ups for qbo -! - real :: knob_ugwp_qbolev = 500.e2 ! fixed pressure layer in Pa for "launch" of conv-GWs - real :: knob_ugwp_qbosin = 1.86 ! semiannual cycle of tau_qbo_src in radians - real :: knob_ugwp_qbotav = 2.285e-3 ! additional to "climate" for QBO-sg forcing - real :: knob_ugwp_qboamp = 1.191e-3 ! additional to "climate" QBO - real :: knob_ugwp_qbotau = 10. ! relaxation time scale in days - real :: knob_ugwp_qbolat = 15. ! qbo-domain for extra-forcing - real :: knob_ugwp_qbowid = 7.5 ! qbo-attenuation for extra-forcing - character(len=8) :: knob_ugwp_orosolv='pss-1986' - - character(len=255) :: ugwp_qbofile = 'qbo_zmf_2009_2018.nc' - character(len=255) :: ugwp_taufile = 'ugwp_limb_tau.nc' - -! character(len=250) :: knob_ugwp_qbofile='qbo_zmf_2009_2018.nc'! -! character(len=250) :: knob_ugwp_amffile='mern_zmf_amf_12month.nc' -! character(len=255) :: file_limb_tab='ugwp_limb_tau.nc' - -! integer, parameter :: ny_tab=73, nt_tab=14 -! real, parameter :: rdy_tab = 1./2.5, rdd_tab = 1./30. -! real :: days_tab(nt_tab), lat_tab(ny_tab) -! real :: abmf_tab(ny_tab,nt_tab) - - integer :: ugwp_azdir - integer :: ugwp_stoch - - integer :: ugwp_src - integer :: ugwp_nws - real :: ugwp_effac - -! - integer :: knob_ugwp_version = 0 - integer :: launch_level = 55 -! - namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & - knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & - knob_ugwp_ndx4lh, knob_ugwp_version, knob_ugwp_palaunch, knob_ugwp_nslope, knob_ugwp_lzmax, & - knob_ugwp_lzmin, knob_ugwp_lzstar, knob_ugwp_lhmet, knob_ugwp_tauamp, knob_ugwp_taumin, & - knob_ugwp_qbolev, knob_ugwp_qbosin, knob_ugwp_qbotav, knob_ugwp_qboamp, knob_ugwp_qbotau, & - knob_ugwp_qbolat, knob_ugwp_qbowid, knob_ugwp_orosolv - -!&cires_ugwp_nml -! knob_ugwp_solver=2 -! knob_ugwp_source=1,1,1,0 -! knob_ugwp_wvspec=1,32,32,32 -! knob_ugwp_azdir =2, 4, 4,4 -! knob_ugwp_stoch =0, 0, 0,0 -! knob_ugwp_effac=1, 1, 1,1 -! knob_ugwp_doaxyz=1 -! knob_ugwp_doheat=1 -! knob_ugwp_dokdis=0 -! knob_ugwp_ndx4lh=4 -!/ -! -! allocatable arrays, initilized during "cires_ugwp_init" & -! released during "cires_ugwp_finalize" -! - real, allocatable :: kvg(:), ktg(:), krad(:), kion(:) - real, allocatable :: zkm(:), pmb(:) - real, allocatable :: rfdis(:), rfdist(:) - integer :: levs_rf - real :: pa_rf, tau_rf -! -! tabulated GW-sources -! - integer :: ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t - real, allocatable :: ugwp_taulat(:), ugwp_qbolat(:) - real, allocatable :: tau_limb(:,:), days_limb(:) - real, allocatable :: uzmf_merra(:,:,:), days_merra(:), pmb127(:) - real, allocatable :: uqboe(:,:) - real, allocatable :: days_y4ddd(:), zkm127(:) - real, allocatable :: tau_qbo(:), stau_qbo(:) - integer,allocatable :: days_y4md(:) - real, allocatable :: vert_qbo(:) - -! -! limiters -! - real, parameter :: latqbo =20., widqbo=15., taurel = 21600. - integer, parameter :: kz2 = 127-7, kz1= 127-49, kz5=5 ! 64km - 18km -! - -!====================================================================== - real, parameter :: F_coriol=1 ! Coriolis effects - real, parameter :: F_nonhyd=1 ! Nonhydrostatic waves - real, parameter :: F_kds =0 ! Eddy mixing due to GW-unstable below - real, parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw - real, parameter :: iPr_turb =1./3., iPr_mol =1.95 - real, parameter :: rhp1=1./hps, rh2=0.5*rhp1, rhp4 = rh2*rh2 - real, parameter :: khp = 0.287*rhp1 ! R/Cp/Hp - real, parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model - - contains -! -! ----------------------------------------------------------------------- -! -! init of cires_ugwp (_init) called from CCPP cap file -! -! ----------------------------------------------------------------------- - - - - subroutine cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat_gfs, con_pi, & - con_rerth, fn_nml2, lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, & - cgwf, pa_rf_in, tau_rf_in, errmsg, errflg) -! -! input_nml_file ='input.nml'=fn_nml ..... OLD_namelist and cdmvgwd(4) Corrected Bug Oct 4 -! - use netcdf - use ugwp_oro_init_v1, only : init_oro_gws - use ugwp_conv_init_v1, only : init_conv_gws - use ugwp_fjet_init_v1, only : init_fjet_gws - use ugwp_okw_init_v1, only : init_okw_gws - use ugwp_wmsdis_init_v1, only : initsolv_wmsdis - - use ugwp_lsatdis_init_v1, only : initsolv_lsatdis - - - use ugwp_wmsdis_init_v1, only : ilaunch, nslope, lhmet, lzmax, lzmin, lzstar - use ugwp_wmsdis_init_v1, only : tau_min, tamp_mpa - implicit none - - integer, intent (in) :: me - integer, intent (in) :: master - integer, intent (in) :: nlunit - integer, intent (in) :: logunit - integer, intent (in) :: lonr - integer, intent (in) :: levs - integer, intent (in) :: latr - integer, intent (in) :: jdat_gfs(8) - real, intent (in) :: ak(levs+1), bk(levs+1), pref - real, intent (in) :: dtp - real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW dims(2) !!! - real, intent (in) :: pa_rf_in, tau_rf_in, con_pi, con_rerth - - character(len=64), intent (in) :: fn_nml2 - character(len=64), parameter :: fn_nml='input.nml' - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! character, intent (in) :: input_nml_file -! integer, parameter :: logunit = 6 - integer :: ios - logical :: exists - real :: dxsg - - integer :: ncid, iernc, vid, dimid, status - integer :: k - integer :: ddd_ugwp, curday_ugwp - real, dimension(6) :: avqbo = (/0.05, 0.1, 0.25, 0.5, 0.75, 0.95/) -! - if (me == master) print *, trim (fn_nml), ' GW-namelist file ' - inquire (file =trim (fn_nml) , exist = exists) -! - if (.not. exists) then - if (me == master) & - write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' - else - open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = cires_ugwp_nml) - close (nlunit) -! - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - - strsolver= knob_ugwp_orosolv - pa_rf = pa_rf_in - tau_rf = tau_rf_in - - curday_ugwp = jdat_gfs(1)*10000 + jdat_gfs(2)*100 +jdat_gfs(3) - call calendar_ugwp(jdat_gfs(1), jdat_gfs(2), jdat_gfs(3), ddd_ugwp) - -! write version number and namelist to log file - if (me == master) then - write (logunit, *) " ================================================================== " - write (logunit, *) "cires_ugwp_namelist_extended_v1" - write (logunit, nml = cires_ugwp_nml) - write (logunit, *) " ================================================================== " - - write (6, *) " ================================================================== " - write (6, *) "cires_ugwp_namelist_extended_v1" - write (6, nml = cires_ugwp_nml) - write (6, *) " ================================================================== " - write (6, *) "calendar_ugwp ddd_ugwp=", ddd_ugwp - write (6, *) "calendar_ugwp curday_ugwp=", curday_ugwp - write (6, *) " ================================================================== " - write (6, *) ddd_ugwp, ' jdat_gfs ddd of year ' - endif -! -! effective kxw - resolution-aware -! - dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh - kxw = pi2/knob_ugwp_lhmet -! -! kxw = pi2/dxsg -! -! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff -! - -! allocate(fcor(latr), fcor2(latr) ) -! - allocate( kvg(levs+1), ktg(levs+1) ) - allocate( krad(levs+1), kion(levs+1) ) - allocate( zkm(levs), pmb(levs) ) - allocate( rfdis(levs), rfdist(levs) ) - - allocate (vert_qbo(levs)) - -! -! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 -! - - do k=1, levs - pmb(k) = 1.e0*(ak(k) + pref*bk(k)) ! Pa -unit Pref = 1.e5, pmb = Pa - zkm(k) = -hpskm*alog(pmb(k)/pref) - enddo - vert_qbo(1:levs) = 0. - - do k=kz1, kz2 - vert_qbo(k)=1. - if (k.le.(kz1+kz5)) vert_qbo(k) = avqbo(k+1-kz1) - if (k.ge.(kz2-kz5)) vert_qbo(k) = avqbo(kz2+1-k) - if (me == master) print *, 'vertqbo', vert_qbo(k), zkm(k) - enddo - -! -! find ilaunch -! - - do k=levs, 1, -1 - if (pmb(k) .gt. knob_ugwp_palaunch ) exit - enddo - - launch_level = max(k-1, 5) ! above 5-layers from the surface - -! -! Part-1 :init_global_gwdis_v1 -! - call init_global_gwdis_v1(levs, zkm, pmb, kvg, ktg, krad, kion, con_pi, & - pa_rf, tau_rf, me, master) - call rf_damp_init_v1 (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) -! -! Part-2 :init_SOURCES_gws -! - -! -! call init-solver for "stationary" multi-wave spectra and sub-grid oro -! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & - knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) -! -! call init-sources for "non-sationary" multi-wave spectra -! - do_physb_gwsrcs=.true. - - IF (do_physb_gwsrcs) THEN - - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init_v1 ' - if (knob_ugwp_wvspec(4) > 0) then -! okw - call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' - endif - - if (knob_ugwp_wvspec(3) > 0) then -! fronts - call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), & - con_pi, lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' - endif - - if (knob_ugwp_wvspec(2) > 0) then -! conv - call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), & - con_pi, con_rerth, lonr, kxw, cgwf ) - if (me == master) & - print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) - - endif - - ENDIF !IF (do_physb_gwsrcs) -! -! -! Tabulated sources -! -! goto 121 - - iernc=NF90_OPEN(trim(ugwp_taufile), nf90_nowrite, ncid) - - if(iernc.ne.0) then - write(errmsg,'(*(a))') "Cannot open file_limb_tab data-file ", & - trim(ugwp_taufile) - errflg = 1 - return - else - - - status = nf90_inq_dimid(ncid, "lat", DimID) -! if (status /= nf90_noerr) call handle_err(status) -! - status = nf90_inquire_dimension(ncid, DimID, len =ntau_d1y ) - - status = nf90_inq_dimid(ncid, "days", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) - if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd-tlimb ' - allocate (ugwp_taulat(ntau_d1y ), days_limb(ntau_d2t)) - allocate ( tau_limb (ntau_d1y, ntau_d2t )) - - iernc=nf90_inq_varid( ncid, 'DAYS', vid ) - iernc= nf90_get_var( ncid, vid, days_limb) - iernc=nf90_inq_varid( ncid, 'LATS', vid ) - iernc= nf90_get_var( ncid, vid, ugwp_taulat) - iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) - iernc= nf90_get_var( ncid, vid, tau_limb) - - iernc=nf90_close(ncid) - - endif -! - iernc=NF90_OPEN(trim(ugwp_qbofile), nf90_nowrite, ncid) - - if(iernc.ne.0) then - write(errmsg,'(*(a))') "Cannot open qbofile data-file ", & - trim(ugwp_qbofile) - errflg = 1 - return - else - - status = nf90_inq_dimid(ncid, "lat", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d1y ) - status = nf90_inq_dimid(ncid, "lev", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d2z) - status = nf90_inq_dimid(ncid, "days", DimID) - status = nf90_inquire_dimension(ncid, DimID, len =nqbo_d3t ) - if (me == master) print *, nqbo_d1y, nqbo_d2z, nqbo_d3t, ' dims tauqbo ' - allocate (ugwp_qbolat(nqbo_d1y ), days_merra(nqbo_d3t) ) - allocate (zkm127(nqbo_d2z), pmb127(nqbo_d2z)) - allocate ( uzmf_merra (nqbo_d1y, nqbo_d2z, nqbo_d3t )) - allocate ( uqboe (nqbo_d2z, nqbo_d3t )) - allocate (days_y4ddd(nqbo_d3t), days_y4md(nqbo_d3t) ) - allocate (tau_qbo(nqbo_d3t), stau_qbo(nqbo_d3t) ) - - iernc=nf90_inq_varid( ncid, 'DAYS', vid ) - iernc= nf90_get_var( ncid, vid, days_merra) - - iernc=nf90_inq_varid( ncid, 'Y4MD', vid ) - iernc= nf90_get_var( ncid, vid, days_y4md) - - iernc=nf90_inq_varid( ncid, 'Y4DDD', vid ) - iernc= nf90_get_var( ncid, vid, days_y4ddd) - - iernc=nf90_inq_varid( ncid, 'LATS', vid ) - iernc= nf90_get_var( ncid, vid, ugwp_qbolat) - - iernc=nf90_inq_varid( ncid, 'LEVS', vid ) - iernc= nf90_get_var( ncid, vid, zkm127) - - - iernc=nf90_inq_varid( ncid, 'UQBO', vid ) - iernc= nf90_get_var( ncid, vid, uzmf_merra) - - iernc=nf90_inq_varid( ncid, 'TAUQBO', vid ) - iernc= nf90_get_var( ncid, vid, tau_qbo) - - iernc=nf90_inq_varid( ncid, 'STAUQBO', vid ) - iernc= nf90_get_var( ncid, vid, stau_qbo) - iernc=nf90_inq_varid( ncid, 'UQBOE', vid ) - iernc= nf90_get_var( ncid, vid, uqboe) - iernc=nf90_close(ncid) - endif - - if (me == master) then - print * - print *, ' ugwp_tabulated files input ' - print *, ' ugwp_taulat ', ugwp_taulat - print *, ' days ', days_limb - print *, ' TAU-limb ', maxval(tau_limb)*1.e3, minval(tau_limb)*1.e3 - print *, ' TAU-qbo ', maxval(stau_qbo)*1.e3, minval(stau_qbo)*1.e3 - print *, ' YMD-qbo ', maxval(days_y4md), minval(days_y4md) - print *, ' YDDD-qbo ', maxval(days_y4ddd), minval(days_y4ddd) - print *, ' uzmf_merra ',maxval(uzmf_merra), minval(uzmf_merra) - print *, ' uEq_merra ',maxval(uqboe), minval(uqboe) - print * - endif - -! -121 continue -! endif ! tabulated sources SABER/HIRDLS/QBO - -!====================== -! Part-3 :init_SOLVERS -! ===================== -! -! call init-solvers for "broad" non-stationary multi-wave spectra -! - if (knob_ugwp_solver==1) then -! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) - endif - if (knob_ugwp_solver==2) then -! -! re-assign from namelists -! - nslope = knob_ugwp_nslope ! the GW sprctral slope at small-m - lzstar = knob_ugwp_lzstar - lzmax = knob_ugwp_lzmax - lzmin = knob_ugwp_lzmin - lhmet = knob_ugwp_lhmet - tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 - tau_min =knob_ugwp_taumin ! min of GW MF 0.25 mPa - ilaunch = launch_level - kxw = pi2/lhmet - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) - endif -! -! other solvers not yet tested for fv3gfs -! -!< if (knob_ugwp_solver==3) call init_dspdis -!< if (knob_ugwp_solver==4) call init_adodis -! - -!====================== - module_is_initialized = .true. - if (me == master) print *, ' CIRES-ugwp-V1 is initialized ', module_is_initialized - - end subroutine cires_ugwp_init_v1 - - -!============================================= - - - subroutine cires_ugwp_advance -!----------------------------------------------------------------------- -! -! options for the day-to-day variable sources/spectra + diagnostics -! for stochastic "triggers" -! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields -! or use for stochastic GWP-sources "memory" -!----------------------------------------------------------------------- - implicit none -! -! update sources -! a) physics-based triggers for multi-wave -! b) stochastic-based spectra and amplitudes -! c) use "memory" on GW-spectra from previous time-step -! d) update "background" GW dissipation as needed -! - end subroutine cires_ugwp_advance - -! -! ----------------------------------------------------------------------- -! finalize of cires_ugwp (_finalize) -! ----------------------------------------------------------------------- - - - subroutine cires_ugwp_finalize -! -! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" -! before "end" of the FV3GFS -! - implicit none -! -! deallocate arrays employed in: -! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init -! - deallocate( kvg, ktg ) - deallocate( krad, kion ) - deallocate( zkm, pmb ) - deallocate( rfdis, rfdist) - deallocate(ugwp_taulat, ugwp_qbolat) - deallocate(tau_limb, uzmf_merra) - deallocate(days_limb, days_merra, pmb127) - - end subroutine cires_ugwp_finalize - -! -! -! -! - subroutine calendar_ugwp(yr, mm, dd, ddd_ugwp) -! -! computes day of year to get tau_limb forcing written with 1-day precision -! - implicit none - integer, intent(in) :: yr, mm, dd - integer :: ddd_ugwp - - integer :: iw3jdn - integer :: jd1, jddd - jd1 = iw3jdn(yr,1,1) - jddd = iw3jdn(yr,mm,dd) - ddd_ugwp = jddd-jd1+1 - - end subroutine calendar_ugwp - - - subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j2tau, & - j1_qbo,j2_qbo, w1_j1qbo, w2_j2qbo, dexp_latqbo ) - - implicit none -! -! ntau_d1y, ntau_d2t, nqbo_d1y, nqbo_d2z, nqbo_d3t -! ugwp_taulat(:), ugwp_qbolat(:), ugwp_merlat(:) -! - integer :: npts, me, master - integer, dimension(npts) :: j1_tau,j2_tau, j1_qbo, j2_qbo - real , dimension(npts) :: dlat, w1_j1tau, w2_j2tau, w1_j1qbo, w2_j2qbo - real , dimension(npts) :: dexp_latqbo - real :: widqbo2, xabs -! - integer i,j, j1, j2 -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - do j=1,npts - j2_qbo(j) = nqbo_d1y - do i=1, nqbo_d1y - if (dlat(j) < ugwp_qbolat(i)) then - j2_qbo(j) = i - exit - endif - enddo - - - j2_qbo(j) = min(j2_qbo(j),nqbo_d1y) - j1_qbo(j) = max(j2_qbo(j)-1,1) - - if (j1_qbo(j) /= j2_qbo(j) ) then - w2_j2qbo(j) = (dlat(j) - ugwp_qbolat(j1_qbo(j))) & - / (ugwp_qbolat(j2_qbo(j))-ugwp_qbolat(j1_qbo(j))) - - else - w2_j2qbo(j) = 1.0 - endif - w1_j1qbo(j) = 1.0 - w2_j2qbo(j) - -! - enddo -! -! weights for tau_limb w1_j1tau, w2_j2tau -! - do j=1,npts - j2_tau(j) = ntau_d1y - do i=1,ntau_d1y - if (dlat(j) < ugwp_taulat(i)) then - j2_tau(j) = i - exit - endif - enddo - - - j2_tau(j) = min(j2_tau(j),ntau_d1y) - j1_tau(j) = max(j2_tau(j)-1,1) - - if (j1_tau(j) /= j2_tau(j) ) then - w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & - / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) - - else - w2_j2tau(j) = 1.0 - endif - w1_j1tau(j) = 1.0 - w2_j2tau(j) - - enddo - widqbo2 =1./widqbo/widqbo - do j=1,npts - dexp_latqbo(j) =0. - xabs =abs(dlat(j)) - if (xabs .le. latqbo) then - dexp_latqbo(j) = exp(-xabs*xabs*widqbo2) - if (xabs .le. 4.0 ) dexp_latqbo(j) =1. -! print *, ' indx_ugwp dexp=', dexp_latqbo(j), nint(dlat(j)) - endif - enddo - - if (me == master ) then -222 format( 2x, 'vay-wqbo', I4, 5(2x, F10.3)) -223 format( 2x, 'vay-limb', I4, 5(2x, F10.3)) - print *, 'vay_indx_ugwp ', size(dlat), ' npts ', npts - do j=1,npts - j1 = j1_tau(j) - j2 = j2_tau(j) - write(6,223) j, ugwp_taulat(j1), dlat(j), ugwp_taulat(j2), w2_j2tau(j), w1_j1tau(j) - enddo - print * - do j=1,npts - j1 = j1_qbo(j) - j2 = j2_qbo(j) - write(6,222) j, ugwp_qbolat(j1), dlat(j), ugwp_qbolat(j2), w2_j2qbo(j), w1_j1qbo(j) - enddo - endif - end subroutine cires_indx_ugwp - -! - end module cires_ugwp_module_v1 - diff --git a/physics/cires_ugwp_ngw_utils.F90 b/physics/cires_ugwp_ngw_utils.F90 deleted file mode 100644 index 4b2a19884..000000000 --- a/physics/cires_ugwp_ngw_utils.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module cires_ugwp_ngw_utils - - -contains - - - subroutine tau_limb_advance(me, master, im, levs, ddd, curdate, & - j1_tau, j2_tau, ddy_j1tau, ddy_j2tau, tau_sat, kdt ) - - - - - use machine, only : kind_phys - - use cires_ugwp_module_v1, only : ntau_d1y, ntau_d2t - use cires_ugwp_module_v1, only : ugwp_taulat, days_limb, tau_limb - -! use cires_ugwp_module, only : ugwp_qbolat, days_merra, pmb127, days_y4md, days_y4ddd -! use cires_ugwp_module, only : tau_qbo, stau_qbo, uqboe, u2 => uzmf_merra - - implicit none - - integer, intent(in) :: me, master, im, levs, ddd, curdate, kdt - integer, intent(in), dimension(im) :: j1_tau, j2_tau - - real , intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau - - real, intent(out) :: tau_sat(im) - - integer :: i, j1, j2, k, it1, it2, iday - real :: tem, tx1, tx2, w1, w2, day2, day1, ddx - integer :: yr1, yr2 -! - integer :: iqbo1=1 -! - - - - it1 = 2 - do iday=1, ntau_d2t - if (float(ddd) .lt. days_limb(iday) ) then - it2 = iday - exit - endif - enddo - it2 = min(it2,ntau_d2t) - it1 = max(it2-1,1) - if (it2 > ntau_d2t ) then - print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t - stop - endif - w2 = (float(ddd)-days_limb(it1))/(days_limb(it2)-days_limb(it1)) - w1 = 1.0-w2 - do i=1, im - j1 = j1_tau(i) - j2 = j2_tau(i) - tx1 = tau_limb(j1, it1)*ddy_j1tau(i)+tau_limb(j2, it1)*ddy_j2tau(i) - tx2 = tau_limb(j1, it2)*ddy_j1tau(i)+tau_limb(j2, it2)*ddy_j2tau(i) - tau_sat(i) = tx1*w1 + w2*tx2 - enddo - - if (me == master ) then - print*, maxval(tau_limb), minval(tau_limb), ' tau_limb ' - print*, ntau_d2t - print*, days_limb(1) , days_limb(ntau_d2t) , ddd, ' days-taulimb ' - print*, 'curdate ', curdate - print*, maxval(tau_sat), minval(tau_sat), ' tau_sat_fv3 ' - endif - return - - end subroutine tau_limb_advance - -end module cires_ugwp_ngw_utils diff --git a/physics/cires_ugwp_orolm97_v1.F90 b/physics/cires_ugwp_orolm97_v1.F90 deleted file mode 100644 index fd692a825..000000000 --- a/physics/cires_ugwp_orolm97_v1.F90 +++ /dev/null @@ -1,1008 +0,0 @@ -module cires_ugwp_orolm97_v1 - - -contains - - - - subroutine gwdps_oro_v1(im, km, imx, do_tofd, & - pdvdt, pdudt, pdtdt, pkdis, u1,v1,t1,q1,kpbl, & - prsi,del,prsl,prslk, zmeti, zmet, dtp, kdt, hprime, & - oc, oa4, clx4, theta, sigmad, gammad, elvmaxd, & - grav, con_omega, rd, cpd, rv, pi, arad, fv, sgh30, & - dusfc, dvsfc, xlatd, sinlat, coslat, sparea, & - cdmbgwd, me, master, rdxzb, & - zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & - dudt_mtb, dudt_ogw, dudt_tms) -!---------------------------------------- -! ugwp_v1: gwdps_oro_v1 following recent updates of Lott & Miller 1997 -! eventually will be replaced with more "advanced"LLWB -! and multi-wave solver that produce competitive FV3GFS-skills -! -! computation of kref for ogw + coorde diagnostics -! all constants/parameters inside cires_ugwp_initialize.f90 -!---------------------------------------- - - use machine , only : kind_phys - use ugwp_common_v1, only : dw2min, velmin - - use ugwp_oro_init_v1, only : rimin, ric, efmin, efmax , & - hpmax, hpmin, sigfaci => sigfac , & - dpmin, minwnd, hminmt, hncrit , & - rlolev, gmax, veleps, factop , & - frc, ce, ceofrc, frmax, cg, & - fdir, mdir, nwdir, & - cdmb, cleff, fcrit_gfs, fcrit_mtb, & - n_tofd, ze_tofd, ztop_tofd - - use cires_ugwp_module_v1, only : kxw, max_kdis, max_axyz - - use cires_orowam2017, only : oro_wam_2017 - - use cires_vert_orodis_v1, only : ugwp_tofd1d - - -! use sso_coorde, only : pgwd, pgwd4 -!---------------------------------------- - implicit none - real(kind=kind_phys), parameter :: pgwd=1, pgwd4= pgwd - real(kind=kind_phys), parameter :: sigfac = 3, sigfacs = 0.5 - character(len=8) :: strsolver='pss-1986' ! current operational solver or 'wam-2017' - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. - logical, parameter :: do_adjoro = .false. -!---------------------------------------- - - integer, intent(in) :: im, km, imx, kdt - integer, intent(in) :: me, master - logical, intent(in) :: do_tofd - - - - integer, intent(in) :: kpbl(im) ! index for the pbl top layer! - real(kind=kind_phys), intent(in) :: dtp ! time step - real(kind=kind_phys), intent(in) :: cdmbgwd(2) - - real(kind=kind_phys), intent(in) :: hprime(im), oc(im), oa4(im,4), & - clx4(im,4), theta(im), sigmad(im), & - gammad(im), elvmaxd(im) - - real(kind=kind_phys), intent(in) :: grav, con_omega, rd, cpd, rv, & - pi, arad, fv - real(kind=kind_phys), intent(in) :: sgh30(im) - real(kind=kind_phys), intent(in), dimension(im,km) :: & - u1, v1, t1, q1,del, prsl, prslk, zmet - - real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, zmeti - real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), coslat(im) - real(kind=kind_phys), intent(in) :: sparea(im) - -! -!output -phys-tend - real(kind=kind_phys),dimension(im,km),intent(out) :: & - pdvdt, pdudt, pkdis, pdtdt -! output - diag-coorde - real(kind=kind_phys),dimension(im,km),intent(out) :: & - dudt_mtb, dudt_ogw, dudt_tms -! - real(kind=kind_phys),dimension(im) :: rdxzb, zmtb, zogw , & - tau_ogw, tau_mtb, tau_tofd, dusfc, dvsfc - -! -!--------------------------------------------------------------------- -! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 -! 4.*gamma*b_ell*b_ell >= shilmin -! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min -! gamma_min = 1/4*shilmin/sso_min/sso_min -!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 -! 192: cdmbgwd = 0.5, 2.5 -! cleff = 2.5*0.5e-5 * sqrt(192./768.) => lh_eff = 1004. km -! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective OGW-lin -!--------------------------------------------------------------------- -! -! locals SSO -! - real(kind=kind_phys) :: vsigma(im), vgamma(im) - - real(kind=kind_phys) :: ztoph,zlowh,ph_blk, dz_blk - real(kind=kind_phys) :: shilmin, sgrmax, sgrmin - real(kind=kind_phys) :: belpmin, dsmin, dsmax -! real(kind=kind_phys) :: arhills(im) ! not used why do we need? - real(kind=kind_phys) :: xlingfs - -! -! locals mean flow ...etc -! - real(kind=kind_phys), dimension(im,km) :: ri_n, bnv2, ro - real(kind=kind_phys), dimension(im,km) :: vtk, vtj, velco -!mtb - real(kind=kind_phys), dimension(im) :: oa, clx , sigma, gamma, & - elvmax, wk - real(kind=kind_phys), dimension(im) :: pe, ek, up - - real(kind=kind_phys), dimension(im,km) :: db, ang, uds - - real(kind=kind_phys) :: zlen, dbtmp, r, phiang, dbim, zr - real(kind=kind_phys) :: eng0, eng1, cosang2, sinang2 - real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem -! -! tofd -! some constants now in "use ugwp_oro_init" + "use ugwp_common" -! -!================== - real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf - real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 - real(kind=kind_phys), dimension(km) :: epstofd1, krf_tofd1 - real(kind=kind_phys), dimension(km) :: up1, vp1, zpm - - real(kind=kind_phys),dimension(im, km) :: axtms, aytms -! -! ogw -! - logical icrilv(im) -! - real(kind=kind_phys), dimension(im) :: xn, yn, ubar, vbar, ulow, & - roll, bnv2bar, scor, dtfac, xlinv, delks, delks1 -! - real(kind=kind_phys) :: taup(im,km+1), taud(im,km) - real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis - - integer, dimension(im) :: kref, idxzb, ipt, kreflm, iwklm, iwk, izlow - -! -!check what we need -! - real(kind=kind_phys) :: bnv, fr, ri_gw, brvf - real(kind=kind_phys) :: tem, tem1, tem2, temc, temv - real(kind=kind_phys) :: ti, rdz, dw2, shr2, bvf2 - real(kind=kind_phys) :: rdelks, efact, coefm, gfobnv - real(kind=kind_phys) :: scork, rscor, hd, fro, sira - real(kind=kind_phys) :: dtaux, dtauy, zmetp, zmetk - - real(kind=kind_phys) :: grav2, rcpdt, windik, wdir - real(kind=kind_phys) :: sigmin, dxres,sigres,hdxres, cdmb4, mtbridge - - real(kind=kind_phys) :: kxridge, inv_b2eff, zw1, zw2 - real(kind=kind_phys) :: belps, aelps, nhills, selps - - real(kind=kind_phys) :: rgrav, rcpd, rcpd2, rad_to_deg, deg_to_rad - real(kind=kind_phys) :: pi2, rdi, gor, grcp, gocp, gr2, bnv2min - -! -! various integers -! - integer :: kmm1, kmm2, lcap, lcapp1 - integer :: npt, kbps, kbpsp1,kbpsm1 - integer :: kmps, idir, nwd, klcap, kp1, kmpbl, kmll - integer :: k_mtb, k_zlow, ktrial, klevm1 - integer :: i, j, k -! -! initialize gamma and sigma - gamma(:) = gammad(:) - sigma(:) = sigmad(:) -! - rcpdt = 1.0 / (cpd*dtp) - grav2 = grav + grav -! - rgrav = 1.0/grav - rcpd = 1.0/cpd - rcpd2 = 0.5/cpd - rad_to_deg=180.0/pi - deg_to_rad=pi/180.0 - pi2 = 2.*pi - rdi = 1.0/rd - gor = grav/rd - grcp = grav*rcpd - gocp = grcp - gr2 = grav*gor - bnv2min = (pi2/1800.)*(pi2/1800.) -! -! mtb-blocking sigma_min and dxres => cires_initialize -! - sgrmax = maxval(sparea) ; sgrmin = minval(sparea) - dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) - - dxres = pi2*arad/float(imx) - hdxres = 0.5*dxres -! shilmin = sgrmin/nhilmax ! not used - moorthi - -! gammin = min(sso_min/dsmax, 1.) ! moorthi - with this results are not reproducible - gammin = min(sso_min/dxres, 1.) ! moorthi - -! sigmin = 2.*hpmin/dsmax !dxres ! moorthi - this will not reproduce - sigmin = 2.*hpmin/dxres !dxres - -! if (kdt == 1) then -! print *, sgrmax, sgrmin , ' min-max sparea ' -! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax -! print *, 'dxres/dsmax ', dxres, dsmax -! print *, ' shilmin gammin ', shilmin, gammin -! endif - - kxridge = float(imx)/arad * cdmbgwd(2) - - if (me == master .and. kdt == 1) then - print *, ' gwdps_v0 kxridge ', kxridge - print *, ' gwdps_v0 scale2 ', cdmbgwd(2) - print *, ' gwdps_v0 imx ', imx - print *, ' gwdps_v0 gam_min ', gammin - print *, ' gwdps_v0 sso_min ', sso_min - endif - - do i=1,im - idxzb(i) = 0 - zmtb(i) = 0.0 - zogw(i) = 0.0 - rdxzb(i) = 0.0 - tau_ogw(i) = 0.0 - tau_mtb(i) = 0.0 - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - tau_tofd(i) = 0.0 -! - ipt(i) = 0 -! - enddo - - do k=1,km - do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 - dudt_mtb(i,k) = 0.0 - dudt_ogw(i,k) = 0.0 - dudt_tms(i,k) = 0.0 - enddo - enddo - -! ---- for lm and gwd calculation points -!cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 -!cires_ugwp_initialize.F90: real, parameter :: hminmt=50. ! min mtn height (*j*) -!---- for lm and gwd calculation points - - - npt = 0 - - do i = 1,im - if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then - npt = npt + 1 - ipt(npt) = i - endif - enddo - - if (npt == 0) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin - return ! no gwd/mb calculation done - endif -!======================================================== - -! - if (do_adjoro ) then - - do i = 1,im -! arhills(i) = 1.0 -! - sigres = max(sigmin, sigma(i)) -! if (sigma(i) < sigmin) sigma(i)= sigmin - dxres = sqrt(sparea(i)) - if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres - aelps = min(2.*hprime(i)/sigres, 0.5*dxres) - if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) -! -! small-scale "turbulent" oro-scales < sso_min -! - if( aelps < sso_min ) then - -! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm -! - aelps = sso_min - if (belps < sso_min ) then - gamma(i) = 1.0 - belps = aelps*gamma(i) - else - gamma(i) = min(aelps/belps, 1.0) - endif - - sigma(i) = 2.*hprime(i)/aelps - gamma(i) = min(aelps/belps, 1.0) - - endif - - selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill - nhills = min(nhilmax, sparea(i)/selps) -! arhills(i) = max(nhills, 1.0) - -!333 format( ' nhil: ', i6, 4(2x, f9.3), 2(2x, e9.3)) -! if (kdt==1 ) -! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, -! & belps*1.e-3, sigma(i),gamma(i) - - - enddo - endif !(do_adjoro ) - - - - do i=1,npt - iwklm(i) = 2 - idxzb(i) = 0 - kreflm(i) = 0 - enddo - - do k=1,km - do i=1,im - db(i,k) = 0.0 - ang(i,k) = 0.0 - uds(i,k) = 0.0 - enddo - enddo - - kmm1 = km - 1 ; kmm2 = km - 2 ; kmll = kmm1 - lcap = km ; lcapp1 = lcap + 1 - - cdmb4 = 0.25*cdmb - - do i = 1, npt - j = ipt(i) - elvmax(j) = min (elvmaxd(j)*0. + sigfac * hprime(j), hncrit) - izlow(i) = 1 ! surface-level - enddo -! - do k = 1, kmm1 - do i = 1, npt - j = ipt(i) - ztoph = sigfac * hprime(j) - zlowh = sigfacs* hprime(j) - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) -! if (( elvmax(j) <= zmetp) .and. (elvmax(j).ge.zmetk) ) -! & iwklm(i) = max(iwklm(i), k+1 ) - if (( ztoph <= zmetp) .and. (ztoph >= zmetk) ) iwklm(i) = max(iwklm(i), k+1 ) - if (zlowh <= zmetp .and. zlowh >= zmetk) izlow(i) = max(izlow(i),k) - - enddo - enddo -! - do k = 1,km - do i =1,npt - j = ipt(i) - vtj(i,k) = t1(j,k) * (1.+fv*q1(j,k)) - vtk(i,k) = vtj(i,k) / prslk(j,k) - ro(i,k) = rdi * prsl(j,k) / vtj(i,k) ! density mid-levels - taup(i,k) = 0.0 - enddo - enddo -! -! check ri_n or ri_mf computation -! - do k = 1,kmm1 - do i =1,npt - j = ipt(i) - rdz = 1. / (zmet(j,k+1) - zmet(j,k)) - tem1 = u1(j,k) - u1(j,k+1) - tem2 = v1(j,k) - v1(j,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz -! ti = 2.0 / (t1(j,k)+t1(j,k+1)) -! bvf2 = grav*(gocp+rdz*(vtj(i,k+1)-vtj(i,k)))* ti -! ri_n(i,k) = max(bvf2/shr2,rimin) ! richardson number -! - bvf2 = grav2 * rdz * (vtk(i,k+1)-vtk(i,k))/ (vtk(i,k+1)+vtk(i,k)) - - bnv2(i,k+1) = max( bvf2, bnv2min ) - ri_n(i,k+1) = bnv2(i,k)/shr2 ! richardson number consistent with bnv2 -! -! add here computation for ktur and ogw-dissipation fro ve-gfs -! - enddo - enddo - k = 1 - do i = 1, npt - bnv2(i,k) = bnv2(i,k+1) - enddo -! -! level iwklm => zmet(j,k) < sigfac * hprime(j) < zmet(j,k+1) -! - do i = 1, npt - j = ipt(i) - k_zlow = izlow(i) - if (k_zlow == iwklm(i)) k_zlow = 1 - delks(i) = 1.0 / (prsi(j,k_zlow) - prsi(j,iwklm(i))) -! delks1(i) = 1.0 /(prsl(j,k_zlow) - prsl(j,iwklm(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - pe (i) = 0.0 - ek (i) = 0.0 - bnv2bar(i) = 0.0 - enddo -! - do i = 1, npt - k_zlow = izlow(i) - if (k_zlow == iwklm(i)) k_zlow = 1 - do k = k_zlow, iwklm(i)-1 ! kreflm(i)= iwklm(i)-1 - j = ipt(i) ! laye-aver rho, u, v - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) ! trial mean u below - vbar(i) = vbar(i) + rdelks * v1(j,k) ! trial mean v below - roll(i) = roll(i) + rdelks * ro(i,k) ! trial mean ro below -! - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - enddo - enddo -! - do i = 1, npt - j = ipt(i) -! -! integrate from ztoph = sigfac*hprime down to zblk if exists -! find ph_blk, dz_blk like in LM-97 and ifs -! - ph_blk =0. - do k = iwklm(i), 1, -1 - phiang = atan2(v1(j,k),u1(j,k))*rad_to_deg - ang(i,k) = ( theta(j) - phiang ) - if ( ang(i,k) > 90. ) ang(i,k) = ang(i,k) - 180. - if ( ang(i,k) < -90. ) ang(i,k) = ang(i,k) + 180. - ang(i,k) = ang(i,k) * deg_to_rad - uds(i,k) = max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), velmin) -! - if (idxzb(i) == 0 ) then - dz_blk = zmeti(j,k+1) - zmeti(j,k) - pe(i) = pe(i) + bnv2(i,k) *( elvmax(j) - zmet(j,k) ) * dz_blk - - up(i) = max(uds(i,k) * cos(ang(i,k)), velmin) - ek(i) = 0.5 * up(i) * up(i) - - ph_blk = ph_blk + dz_blk*sqrt(bnv2(i,k))/up(i) - -! --- dividing stream lime is found when pe =exceeds ek. oper-l gfs -! if ( pe(i) >= ek(i) ) then - if ( ph_blk >= fcrit_gfs ) then - idxzb(i) = k - zmtb (j) = zmet(j, k) - rdxzb(j) = real(k, kind=kind_phys) - endif - - endif - enddo -! -! alternative expression: zmtb = max(heff*(1. -fcrit_gfs/fr), 0) -! fcrit_gfs/fr -! - goto 788 - - bnv = sqrt( bnv2bar(i) ) - heff = 2.*min(hprime(j),hpmax) - zw2 = ubar(i)*ubar(i)+vbar(i)*vbar(i) - ulow(i) = sqrt(max(zw2,dw2min)) - fr = heff*bnv/ulow(i) - zw1 = max(heff*(1. -fcrit_gfs/fr), 0.0) - zw2 = zmet(j,2) - if (fr > fcrit_gfs .and. zw1 > zw2 ) then - do k=2, kmm1 - zmetp = zmet(j,k+1) - zmetk = zmet(j,k) - if (zw1 <= zmetp .and. zw1 >= zmetk) exit - enddo - idxzb(i) = k - zmtb (j) = zmet(j, k) - else - zmtb (j) = 0. - idxzb(i) = 0 - endif - -788 continue -! -! --- the drag for mtn blocked flow -! - if ( idxzb(i) > 0 ) then - -! (4.16)-ifs - gam2 = gamma(j)*gamma(j) - bgam = 1.0 - 0.18*gamma(j) - 0.04*gam2 - cgam = 0.48*gamma(j) + 0.30*gam2 - - do k = idxzb(i)-1, 1, -1 - zlen = sqrt( (zmtb(j)-zmet(j,k) )/(zmet(j,k ) + hprime(j)) ) - tem = cos(ang(i,k)) - cosang2 = tem * tem - sinang2 = 1.0 - cosang2 -! -! cos =1 sin =0 => 1/r= gam zr = 2.-gam -! cos =0 sin =1 => 1/r= 1/gam zr = 2.- 1/gam -! - rdem = cosang2 + gam2 * sinang2 - rnom = cosang2*gam2 + sinang2 -! -! metoffice dec 2010 -! correction of h. wells & a. zadra for the -! aspect ratio of the hill seen by mean flow -! (1/r , r-inverse below: 2-r) - - rdem = max(rdem, 1.e-6) - r = sqrt(rnom/rdem) - zr = max( 2. - r, 0. ) - - sigres = max(sigmin, sigma(j)) - if (hprime(j)/sigres > dxres) sigres = hprime(j)/dxres - mtbridge = zr * sigres*zlen / hprime(j) -! (4.15)-ifs -! dbtmp = cdmb4 * mtbridge * & -! & max(cos(ang(i,k)), gamma(j)*sin(ang(i,k))) -! (4.16)-ifs - dbtmp = cdmb4*mtbridge*(bgam* cosang2 +cgam* sinang2) - db(i,k)= dbtmp * uds(i,k) - enddo -! - endif - enddo -!............................. -!............................. -! end mtn blocking section -!............................. -!............................. -! -!--- orographic gravity wave drag section -! -! scale cleff between im=384*2 and 192*2 for t126/t170 and t62 -! inside "cires_ugwp_initialize.f90" now -! - kmpbl = km / 2 - iwk(1:npt) = 2 -! -! meto/UK-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! - do k=3,kmpbl - do i=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem < dpmin) iwk(i) = k ! dpmin=50 mb - -!=============================================================== -! lev=111 t=311.749 hkm=0.430522 ps-p(iwk)=52.8958 -! below "hprime" - source of ogws and below zblk !!! -! 27 2 kpbl ~ 1-2 km < hprime -!=============================================================== - enddo - enddo -! -! iwk - adhoc gfs-parameter to select ogw-launch level between -! level ~0.4-0.5 km from surface or/and pbl-top -! in ugwp-v1: options to modify as htop ~ (2-3)*hprime > zmtb -! in ugwp-v0 we ensured that : zogw > zmtb -! - - kbps = 1 - kmps = km - k_mtb = 1 - do i=1,npt - j = ipt(i) - k_mtb = max(1, idxzb(i)) - - kref(i) = max(iwk(i), kpbl(j)+1 ) ! reference level pbl or smt-else ???? - kref(i) = max(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime - - if (kref(i) <= k_mtb) kref(i) = k_mtb + 1 ! layer above zmtb - kbps = max(kbps, kref(i)) - kmps = min(kmps, kref(i)) -! - delks(i) = 1.0 / (prsi(j,k_mtb) - prsi(j,kref(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - bnv2bar(i)= 0.0 - enddo -! - kbpsp1 = kbps + 1 - kbpsm1 = kbps - 1 - k_mtb = 1 -! - do i = 1,npt - k_mtb = max(1, idxzb(i)) - do k = k_mtb,kbps !kbps = max(kref) ;kmps= min(kref) - if (k < kref(i)) then - j = ipt(i) - rdelks = del(j,k) * delks(i) - ubar(i) = ubar(i) + rdelks * u1(j,k) ! mean u below kref - vbar(i) = vbar(i) + rdelks * v1(j,k) ! mean v below kref - roll(i) = roll(i) + rdelks * ro(i,k) ! mean ro below kref - bnv2bar(i) = bnv2bar(i) + .5*(bnv2(i,k)+bnv2(i,k+1))* rdelks - endif - enddo - enddo -! -! orographic asymmetry parameter (oa), and (clx) - do i = 1,npt - j = ipt(i) - wdir = atan2(ubar(i),vbar(i)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(j,mod(nwd-1,4)+1) - clx(i) = clx4(j,mod(nwd-1,4)+1) - enddo -! - do i = 1,npt - dtfac(i) = 1.0 - icrilv(i) = .false. ! initialize critical level control vector - ulow(i) = max(sqrt(ubar(i)*ubar(i)+vbar(i)*vbar(i)),velmin) - xn(i) = ubar(i) / ulow(i) - yn(i) = vbar(i) / ulow(i) - enddo -! - do k = 1, kmm1 - do i = 1,npt - j = ipt(i) - velco(i,k) = 0.5 * ((u1(j,k)+u1(j,k+1))*xn(i)+ (v1(j,k)+v1(j,k+1))*yn(i)) - - enddo - enddo -! -!------------------ -! v0: incorporates latest modifications for kxridge and heff/hsat -! and taulin for fr <=fcrit_gfs -! and concept of "clipped" hill if zmtb > 0. to make -! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data -! it is still used the "single-orowave"-approach along ulow-upwind -! -! in contrast to the 2-orthogonal wave (2otw) schemes of ifs/meto/e-canada -! 2otw scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b -! with 2-stresses: taub_a & taub_b as of Phillips (1984) -!------------------ - taub(:) = 0. ; taulin(:)= 0. - do i = 1,npt - j = ipt(i) - bnv = sqrt( bnv2bar(i) ) - heff = min(hprime(j),hpmax) - - if( zmtb(j) > 0.) heff = max(sigfac*heff-zmtb(j), 0.)/sigfac - if (heff <= 0) cycle - - hsat = fcrit_gfs*ulow(i)/bnv - heff = min(heff, hsat) - - fr = min(bnv * heff /ulow(i), frmax) -! - efact = (oa(i) + 2.) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) -! - coefm = (1. + clx(i)) ** (oa(i)+1.) -! - xlinv(i) = coefm * cleff ! effective kxw for lin-wave - xlingfs = coefm * cleff -! - tem = fr * fr * oc(j) - gfobnv = gmax * tem / ((tem + cg)*bnv) -! -!new specification of xlinv(i) & taulin(i) - - sigres = max(sigmin, sigma(j)) - if (heff/sigres > hdxres) sigres = heff/hdxres - inv_b2eff = 0.5*sigres/heff - kxridge = 1.0 / sqrt(sparea(j)) - xlinv(i) = xlingfs !or max(kxridge, inv_b2eff) ! 6.28/lx ..0.5*sigma(j)/heff = 1./lridge - taulin(i) = 0.5*roll(i)*xlinv(i)*bnv*ulow(i)*heff*heff*pgwd4 - - if ( fr > fcrit_gfs ) then - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact ! nonlinear flux tau0...xlinv(i) -! - else -! taub(i) = taulin(i) ! linear flux for fr <= fcrit_gfs - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact -! - endif -! -! - k = max(1, kref(i)-1) - tem = max(velco(i,k)*velco(i,k), dw2min) - scor(i) = bnv2(i,k) / tem ! scorer parameter below kref level -! -! diagnostics for zogw > zmtb -! - zogw(j) = zmeti(j, kref(i) ) - enddo -! -!----set up bottom values of stress -! - do k = 1, kbps - do i = 1,npt - if (k <= kref(i)) taup(i,k) = taub(i) - enddo - enddo - - if (strsolver == 'pss-1986') then - -!====================================================== -! v0-gfs orogw-solver of palmer et al 1986 -"pss-1986" -! in v1-orogw linsatdis of "wam-2017" -! with llwb-mechanism for -! rotational/non-hydrostat ogws important for -! highres-fv3gfs with dx < 10 km -!====================================================== - - do k = kmps, kmm1 ! vertical level loop from min(kref) - kp1 = k + 1 - do i = 1, npt -! - if (k >= kref(i)) then - icrilv(i) = icrilv(i) .or. ( ri_n(i,k) < ric).or. (velco(i,k) <= 0. ) - endif - enddo -! - do i = 1,npt - if (k >= kref(i)) then - if (.not.icrilv(i) .and. taup(i,k) > 0.0 ) then - temv = 1.0 / max(velco(i,k), velmin) -! - if (oa(i) > 0. .and. kp1 < kref(i)) then -! - scork = bnv2(i,k) * temv * temv - rscor = min(1.0, scork / scor(i)) - scor(i) = scork - else - rscor = 1. - endif -! - brvf = sqrt(bnv2(i,k)) ! brent-vaisala frequency interface -! tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*velco(i,k)*0.5 - - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf*0.5 & - * max(velco(i,k), velmin) - hd = sqrt(taup(i,k) / tem1) - fro = brvf * hd * temv -! -! rim is the "wave"-richardson number by palmer,shutts, swinbank 1986 -! - - tem2 = sqrt(ri_n(i,k)) - tem = 1. + tem2 * fro - ri_gw = ri_n(i,k) * (1.0-fro) / (tem * tem) -! -! check stability to employ the 'dynamical saturation hypothesis' -! of palmer,shutts, swinbank 1986 -! - if (ri_gw <= ric .and.(oa(i) <= 0. .or. kp1 >= kref(i) )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf - taup(i,kp1) = tem1 * hd * hd - else - taup(i,kp1) = taup(i,k) * rscor - endif -! - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - endif - endif - enddo - enddo -! -! zero momentum deposition at the top model layer -! - taup(1:npt,km+1) = taup(1:npt,km) -! -! calculate wave acc-n: - (grav)*d(tau)/d(p) = taud -! - do k = 1,km - do i = 1,npt - taud(i,k) = grav*(taup(i,k+1) - taup(i,k))/del(ipt(i),k) - enddo - enddo - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!------if the gravity wave drag would force a critical line in the -!------layers below sigma=rlolev during the next deltim timestep, -!------then only apply drag until that critical line is reached. -! empirical implementation of the llwb-mechanism: lower level wave breaking -! by limiting "ax = dtfac*ax" due to possible llwb around kref and 500 mb -! critical line [v - ax*dtp = 0.] is smt like "llwb" for stationary ogws -!2019: this option limits sensitivity of taux/tauy to increase/decrease of taub -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - do k = 1,kmm1 - do i = 1,npt - if (k >= kref(i) .and. prsi(ipt(i),k) >= rlolev) then - - if(taud(i,k) /= 0.) then - tem = dtp * taud(i,k) ! tem = du/dt-oro*dt => U/dU vs 1 - dtfac(i) = min(dtfac(i),abs(velco(i,k)/tem)) ! reduce Ax= Ax*(1, or U/dU <=1) -! dtfac(i) = 1.0 - endif - endif - enddo - enddo -! -!--------------------------- orogw-solver of gfs pss-1986 -! - else -! -!-----------Unified orogw-solver of wam2017 -! -! sigres = max(sigmin, sigma(j)) -! if (heff/sigres.gt.dxres) sigres=heff/dxres -! inv_b2eff = 0.5*sigres/heff -! xlinv(i) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./lridge - - dtfac(:) = 1.0 - - call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & - dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsl, & - grav, con_omega, rd, & - del, sigma, hprime, gamma, theta, sinlat, xlatd, taup, taud, pkdis) - - endif ! oro_wam_2017 - linsatdis-solver of wam-2017 -! -!---- above orogw-solver of wam2017 -! -! tofd as in beljaars-2004 -! -! --------------------------- - if( do_tofd ) then - axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0) then - print *, 'vay do_tofd from surface to ', ztop_tofd - endif - do i = 1,npt - j = ipt(i) - zpbl = zmet( j, kpbl(j) ) - - sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of ls-sso - - zsurf = zmeti(j,1) - do k=1,km - zpm(k) = zmet(j,k) - up1(k) = u1(j,k) - vp1(k) = v1(j,k) - enddo - - call ugwp_tofd1d(km, cpd, sigflt, elvmaxd(j), zsurf, zpbl, & - up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1,km - axtms(j,k) = utofd1(k) - aytms(j,k) = vtofd1(k) -! -! add tofd to gw-tendencies -! - pdvdt(j,k) = pdvdt(j,k) + aytms(j,k) - pdudt(j,k) = pdudt(j,k) + axtms(j,k) - enddo -!2018-diag - tau_tofd(j) = sum( utofd1(1:km)* del(j,1:km)) - enddo - endif ! do_tofd - -!-------------------------------------------- -! combine oro-drag effects MB +TOFD + OGWs -!-------------------------------------------- -! + diag-3d - - dudt_tms = axtms - tau_ogw = 0. - tau_mtb = 0. - - do k = 1,km - do i = 1,npt - j = ipt(i) -! - eng0 = 0.5*(u1(j,k)*u1(j,k)+v1(j,k)*v1(j,k)) -! - if ( k < idxzb(i) .and. idxzb(i) /= 0 ) then -! -! if blocking layers -- no ogws -! - dbim = db(i,k) / (1.+db(i,k)*dtp) - pdvdt(j,k) = - dbim * v1(j,k) +pdvdt(j,k) - pdudt(j,k) = - dbim * u1(j,k) +pdudt(j,k) - eng1 = eng0*(1.0-dbim*dtp)*(1.-dbim*dtp) - - dusfc(j) = dusfc(j) - dbim * u1(j,k) * del(j,k) - dvsfc(j) = dvsfc(j) - dbim * v1(j,k) * del(j,k) -!2018-diag - dudt_mtb(j,k) = -dbim * u1(j,k) - tau_mtb(j) = tau_mtb(j) + dudt_mtb(j,k)* del(j,k) - - else -! -! ogw-s above blocking height -! - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) * pgwd - dtauy = taud(i,k) * yn(i) * pgwd - - pdvdt(j,k) = dtauy +pdvdt(j,k) - pdudt(j,k) = dtaux +pdudt(j,k) - - unew = u1(j,k) + dtaux*dtp ! pdudt(j,k)*dtp - vnew = v1(j,k) + dtauy*dtp ! pdvdt(j,k)*dtp - eng1 = 0.5*(unew*unew + vnew*vnew) -! - dusfc(j) = dusfc(j) + dtaux * del(j,k) - dvsfc(j) = dvsfc(j) + dtauy * del(j,k) -!2018-diag - dudt_ogw(j,k) = dtaux - tau_ogw(j) = tau_ogw(j) +dtaux*del(j,k) - endif -! -! local energy deposition sso-heat -! - pdtdt(j,k) = max(eng0-eng1,0.)*rcpdt - enddo - enddo -! dusfc w/o tofd sign as in the era-i, merra and cfsr - do i = 1,npt - j = ipt(i) - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) - tau_mtb(j) = -rgrav * tau_mtb(j) - tau_ogw(j) = -rgrav * tau_ogw(j) - tau_tofd(j) = -rgrav * tau_tofd(j) - enddo - - return - - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0) then - print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' -! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw_epsoro' - print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' - print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' -! print *, maxval(tau_tofd), ' tau_tofd ' -! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' -! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' - if (maxval(abs(pdudt))*86400. > 100.) then - - print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' - print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' - print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' - print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' - print *, maxval(del), minval(del), ' del gwdps-v0 ' - print *, maxval(zmet),minval(zmet), 'zmet' - print *, maxval(zmeti),minval(zmeti), 'zmeti' - print *, maxval(prsi), minval(prsi), ' prsi ' - print *, maxval(prsl), minval(prsl), ' prsl ' - print *, maxval(ro), minval(ro), ' ro-dens ' - print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' bnv2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' - print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' - print * - do i =1, npt - j= ipt(i) - print *,zogw(j)/hprime(j), zmtb(j)/hprime(j), & - zmet(j,1)*1.e-3, nint(hprime(j)/sigma(j)) -! -!.................................................................... -! -! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m -! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km -! we must exclude blocking by small ridges -! vay-kref < iblk zogw-lev 15 block-level: 39 -! -! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters -! max(sqrt(u1(j,k)*u1(j,k) + v1(j,k)*v1(j,k)), minwnd) -! max(dw2,dw2min) * rdz * rdz -! ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) -! tem = max(velco(i,k)*velco(i,k), 0.1) -! temv = 1.0 / max(velco(i,k), 0.01) -! & * max(velco(i,k),0.01) -!.................................................................... - enddo - print * - stop - endif - endif - -!cires_ugwp_solv2_v1.f90 - return - end subroutine gwdps_oro_v1 - - -end module cires_ugwp_orolm97_v1 diff --git a/physics/cires_ugwp_solv2_v1_mod.F90 b/physics/cires_ugwp_solv2_v1_mod.F90 deleted file mode 100644 index 46a5fb833..000000000 --- a/physics/cires_ugwp_solv2_v1_mod.F90 +++ /dev/null @@ -1,829 +0,0 @@ -module cires_ugwp_solv2_v1_mod - - -contains - - -!--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 -! dissipative solver with NonHyd/ROT-effects -! reflected GWs treated as waves with "negligible" flux, -! they are out of given column -!--------------------------------------------------- - subroutine cires_ugwp_solv2_v1(im, levs, dtp , & - tm , um, vm, qm, prsl, prsi, zmet, zmeti, & - prslk, xlatd, sinlat, coslat, & - grav, cpd, rd, rv, omega, pi, fv, & - pdudt, pdvdt, pdtdt, dked, tauabs, wrms, trms, & - tau_ngw, mpi_id, master, kdt) -! -!-------------------------------------------------------------------------------- -! nov 2015 alternative gw-solver for nggps-wam -! nov 2017 nh/rotational gw-modes for nh-fv3gfs -! oct 2019 adding empirical satellite-based -! source function and *F90 CIRES-style of the code -! -------------------------------------------------------------------------------- -! - - use machine, only : kind_phys - - use cires_ugwp_module_v1,only : krad, kvg, kion, ktg - - use cires_ugwp_module_v1,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - - use ugwp_common_v1 , only : dw2min, velmin, hpscale, rhp, rh4 -! - use ugwp_wmsdis_init_v1, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & - maxdudt, gw_eff, dked_min, dked_max, maxdtdt, & - nslope, ilaunch, zms, & - zci, zdci, zci4, zci3, zci2, & - zaz_fct, zcosang, zsinang, nwav, nazd, & - zcimin, zcimax, rimin, sc2, sc2u, ric -! - implicit none -!23456 - - integer, intent(in) :: levs ! vertical level - integer, intent(in) :: im ! horiz tiles - - real ,intent(in) :: dtp ! model time step - real ,intent(in) :: vm(im,levs) ! meridional wind - real ,intent(in) :: um(im,levs) ! zonal wind - real ,intent(in) :: qm(im,levs) ! spec. humidity - real ,intent(in) :: tm(im,levs) ! kinetic temperature - - real ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real ,intent(in) :: prslk(im,levs) ! mid-layer exner function - real ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav - real ,intent(in) :: prsi(im,levs+1) ! interface pressure - real ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters - real ,intent(in) :: xlatd(im) ! lat was in radians, now with xlat_d in degrees - real ,intent(in) :: sinlat(im) - real ,intent(in) :: coslat(im) - real ,intent(in) :: tau_ngw(im) - - integer, intent(in):: mpi_id, master, kdt - - real ,intent(in) :: grav, cpd, rd, rv, omega, pi, fv -! -! -! out-gw effects -! - real ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency - real ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency - real ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp - real ,intent(out) :: dked(im,levs) ! gw-eddy diffusion -! -! GW diagnostics => next move it to "module_gw_diag" -! - real ,intent(out) :: tauabs(im,levs) ! - real ,intent(out) :: wrms(im,levs) ! - real ,intent(out) :: trms(im,levs) ! - - real :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) -! -! local =========================================================================================== - real :: taux(levs+1) ! EW component of vertical momentum flux (pa) - real :: tauy(levs+1) ! NS component of vertical momentum flux (pa) - real :: fpu(nazd, levs+1) ! az-momentum flux - real :: ui(nazd, levs+1) ! azimuthal wind - - real :: fden_bn(levs+1) ! density/brent - real :: flux_z(nwav,levs+1) - real :: flux(nwav, nazd) -! -! =============================================================================================== -! ilaunch:levs ....... MOORTHI's improvements -! all computations of GW-effects include interface layers from ilaunch+1 to levs +1 -! at k=levs+1, extrapolation of MF-state has been made, "ideally" all spectral modes should -! be absorbed; 2-options for this "ideal" requirement -! a) properly truncate GW-spectra ; b) dissipate all GW-energy in the top layers ( GW-sponge) -!===================================================================================================== -! - real :: bn(levs+1) ! interface BV-frequency - real :: bn2(levs+1) ! interface BV*BV-frequency - real :: rhoint(levs+1) ! interface density - real :: uint(levs+1) ! interface zonal wind - real :: vint(levs+1) ! meridional wind - - real :: irhodz_mid(levs), dzdt(levs+1), bnk(levs+1), rhobnk(levs+1) - - real :: v_zmet(levs+1) - real :: vueff(levs+1) - real :: dfdz_v(nazd, levs) ! axj = -df*rho/dz directional momentum deposition - - - real :: suprf(levs+1) ! RF-super linear dissipation - - real, dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet - real, dimension(levs+1) :: aprsi, azmeti - - real :: wrk3(levs) - real, dimension(levs) :: uold, vold, told, unew, vnew, tnew - real, dimension(levs) :: dktur, rho, rhomid, adif, cdif - - real :: rdci(nwav), rci(nwav) - real :: wave_act(nwav, nazd) ! active waves at given vert-level - real :: ul(nazd) ! velocity in azimuthal direction at launch level - real :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real :: c2f2, cf1 - - - real :: flux_norm ! norm-factor - real :: taub_src, rho_src -! -! scalars -! - real :: zthm, dtau, cgz, ucrit_maxdc - real :: vm_zflx_mode, vc_zflx_mode - real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 - real :: ucrit_max - real :: pwrms, ptrms - real :: zu, zcin, zcin2, zcin3, zcin4, zcinc - real :: zatmp, fluxs, zdep, ze1, ze2 -! - real :: rcpdl, grav2cpd, rcpd, rcpd2, pi2, rad_to_deg - real :: deg_to_rad, rdi, gor, grcp, gocp, bnv2min, bnv2max, gr2 - real :: grav2, rgrav, rgrav2, mkzmin, mkz2min -! - real :: zdelp, zdelm, taud_min - real :: tvc, tvm, ptc, ptm - real :: umfp, umfm, umfc, ucrit3 - real :: fmode, expdis, fdis - real :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit - real :: v_wdi, v_wdpc - real :: ugw, vgw, ek1, ek2, rdtp, rdtp2 - - integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop -! -! Kturb-part -! - - real :: uz, vz, shr2 , ritur, ktur - - real :: kamp, zmetk, zgrow - real :: stab, stab_dt, dtstab - integer :: nstab, ist, anstab(levs) - real :: w1, w2, w3, dtdif - - real :: dzmetm, dzmetp, dzmetf, bdif, kturp - real :: bnrh_src -!-------------------------------------------------------------------------- -! - - if (mpi_id == master .and. kdt < 2) then - print *, im, levs, dtp, kdt, ' vay-solv2-v1' - print *, minval(tm), maxval(tm), ' min-max-tm ' - print *, minval(vm), maxval(vm), ' min-max-vm ' - print *, minval(um), maxval(um), ' min-max-um ' - print *, minval(qm), maxval(qm), ' min-max-qm ' - print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' - print *, minval(prsi), maxval(prsi), ' min-max-Pint ' - print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' - print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' - print *, minval(prslk), maxval(prslk), ' min-max-Exner ' - print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' - print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! - endif - - if (idebug_gwrms == 1) then - tauabs=0.0; wrms =0.0 ; trms =0.0 - endif - - - grav2 = grav + grav - rgrav = 1.0/grav - rgrav2 = rgrav*rgrav - rdi = 1.0/rd - gor = grav/rd - gr2 = grav*gor - rcpd = 1.0/cpd - rcpd2 = 0.5/cpd - rcpdl = cpd*rgrav ! 1/[g/cp] == cp/g - pi2 = 2.0*pi - grcp = grav*rcpd - gocp = grcp - grav2cpd = grav*grcp ! g*(g/cp)= g^2/cp - rad_to_deg=180.0/pi - deg_to_rad=pi/180.0 - bnv2min = (pi2/1800.)*(pi2/1800.) - bnv2max = (pi2/30.)*(pi2/30.) - mkzmin = pi2/80.0e3 - mkz2min = mkzmin*mkzmin - - rci(:) = 1./zci(:) - rdci(:) = 1./zdci(:) - - rdtp = 1./dtp - rdtp2 = 0.5*rdtp -! -! launch level control ksrc > 2 -! - - ksrc= max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop= levs+1 - - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo - -!----------------------------------------------------------- -! column-based j=1,im pjysics with 1D-arrays -!----------------------------------------------------------- - DO j=1, im - - jl =j - tx1 = 2*omega * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max -! -! ngw-fluxes at all gridpoints (with tau_min at least) -! - taub_src = max(tau_ngw(jl), tau_min) - aum(km2:levs) = um(jl,km2:levs) - avm(km2:levs) = vm(jl,km2:levs) - atm(km2:levs) = tm(jl,km2:levs) - aqm(km2:levs) = qm(jl,km2:levs) - aprsl(km2:levs) = prsl(jl,km2:levs) - azmet(km2:levs) = zmet(jl,km2:levs) - aprsi(km2:levs+1) = prsi(jl,km2:levs+1) - azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) - - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - -! --------------------------------------------- -! interface mean flow parameters launch -> levs+1 -! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk) * (1. +fv*aqm(jk)) - tvm = atm(jk-1) * (1. +fv*aqm(jk-1)) - ptc = tvc/ prslk(jl, jk) - ptm = tvm/prslk(jl,jk-1) -! - zthm = 2.0 / (tvc+tvm) -! - uint(jk) = 0.5 *(aum(jk-1)+aum(jk)) - vint(jk) = 0.5 *(avm(jk-1)+avm(jk)) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = azmeti(jk+1)-azmeti(jk) ! >0 ...... dz-meters - zdelm = 1./(azmet(jk)-azmet(jk-1)) ! 1/dz ...... 1/meters - dzdt(jk) = dtp/zdelp -! -! bvf2 = grav2 * zdelm * (ptc-ptm)/ (ptc + ptm) ! N2=[g/PT]*(dPT/dz) -! - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) - bnk(jk) = bn(jk)*v_kxw - rhobnk(jk)=rhoint(jk)/bnk(jk)*v_kxw - wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src - - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] -! -! -! diagnostics -Kzz above PBL -! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - kamp = sqrt(shr2)*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min)+kvg(k), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur*0. + 2.e-5*exp( zmetk) - enddo - - if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) - enddo - endif - -! -! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! - jk = levs - - suprf(ktop) = kion(jk) - - rhoint(ktop) = aprsi(ktop)*rdi/atm(jk) - - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) - - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) - bnk(ktop) = bn(ktop)*v_kxw - - rhobnk(ktop) = rhoint(ktop)/bnk(ktop)*v_kxw - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi - bnrh_src = bvi/rhoint(ksrc) -! -! define intrinsic velocity (relative to ilaunch) u(z)-u(zo), and coefficinets -! ------------------------------------------------------------------------------------------ - do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) - enddo -! - do jk=ksrc, ktop - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. - enddo - enddo -! ----------------------------------------- -! set launch momentum flux spectral density -! ----------------------------------------- - - fpu(1, ksrc) =0. - do inc=1,nwav - zcin = zci(inc) - zcin4 = zci4(inc)/bvi4 -! - if(nslope == 0) then - zcin3 = zci3(inc)/bvi3 - flux(inc,1) = zcin/(1.+zcin3) - endif - - if(nslope == 1) flux(inc,1) = zcin/(1.+zcin4) - if(nslope == 2) flux(inc,1)= zcin/(1.+zcin4*zcin*rcms) - -! integrate (flux x dx) - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) - - do iaz=1,nazd - akzw(inc, iaz,ksrc:ktop) = bvi*rci(inc) - enddo - - enddo -! - flux_norm = taub_src / fpu(1, ksrc) -! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - enddo - -! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - bnrh_src=bnrh_src*flux_norm - do jk=ksrc, ktop - fden_bn(jk) = bnrh_src*rhoint(jk) / bn(jk) !*bvi/rhoint(ksrc) - enddo - -! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo - - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif - -! copy flux-1 into other azimuths -! -------------------------------- - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) - enddo - enddo - -! constant flux below ilaunch - do jk=km1, ksrc - do inc=1, nwav - flux_z(inc,jk)=flux(inc,1) - enddo - enddo - - wave_act(:,:) = 1.0 -! vertical do-loop - do jk=ksrc, levs - jkp = jk+1 -! azimuth do-loop - do iaz=1, nazd - - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) -! wave-cin loop - do inc=1, nwav - - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if(wave_act(inc,iaz) == 1.0) then -!======================================================================= -! discrete mode -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -!======================================================================= - - v_cdp = zcin - umfp - - if (v_cdp .le. ucrit_max) then -! -! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max ; wave's absorption -! - wave_act(inc,iaz) =0. - akzw(inc, iaz, jkp) = pi/v_zmet(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - flux_z(inc,jkp) = fluxs -! ucrit_maxdc =0. - else - - v_wdp = v_kxw*v_cdp - wdop2 = v_wdp* v_wdp - v_cdp2=v_cdp*v_cdp -! -! rotational cut-off -! - cdf2 = v_cdp2 - c2f2 - - if (cdf2 > 0.0) then - kzw2 = (bn2(jkp)-wdop2)/Cdf2 - else - kzw2 = mkz2min - endif - - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw -! -!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) -! Kds = kxw*Cdf1*rhp2/kzw3 -! - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + supRF(jk) ! supRF - diss due to FRF-FV3dycore for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc -! - ze1 = v_kzi*v_zmet(jk) - - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1./(1.+ ze1) - endif - -! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) - - else ! kzw2 <= mkz2min large "Lz"-reflection - - expdis = 1.0 - v_kzw = mkzmin - - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - endif - - fdis = fmode*expdis -! -! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 -! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] -! -! fluxs= fden_bn(jkp)*cdf2*zcinc - fluxs= fden_bn(jkp)*sqrt(cdf2) - -! -! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin -! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) -! - zdep = wave_act(inc,iaz)* (fdis-fluxs) - if(zdep > 0.0 ) then -! subs on sat-limit - flux(inc,iaz) = fluxs - flux_z(inc,jkp) = fluxs - else -! assign dis-ve flux - flux(inc,iaz) = fdis - flux_z(inc,jkp) = fdis - endif - -! cgz = bnk(jk)/max(mkz2min, kzw2) - - dtau = flux_z(inc,jk)-flux_z(inc,jkp) - if (dtau .lt. 0) flux_z(inc,jkp) = flux_z(inc,jk) - -! if (dtau .ge. ucrit_maxdc) then -! flux_z(inc,jkp) = max(flux_z(inc,jk)-ucrit_maxdc, 0.) -! ze1 = zci(inc)-umfc-ucrit_maxdc -! write(6,287) dzdt(jk)/cgz, dtau/ucrit_maxdc, flux_z(inc,jkp)*1.e3, fluxs*1.e3, jk, zci(inc), ze1 -! -! endif -! 287 format(' dtau >ucrit_max', 4(2x, F12.7), I4, 2x, 2(2x,F8.3)) -! - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 - - -! - enddo ! wave-inc-loop -! -! integrate over spectral modes fpu(y, z, azimuth) wave_act(jl,inc,iaz)*flux(jl,inc,iaz)*[d("zcinc")] -! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. -! new arrays - - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif - - - dfdz_v(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - - zcinc =zdci(inc) - vc_zflx_mode = flux(inc,iaz) - fpu(iaz, jkp) = fpu(iaz,jkp) + vc_zflx_mode*zcinc - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! (heat deposition integration over spectral mode for each azimuth -! later sum over selected azimuths as "non-negative" scalars) -! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc - zdelp = wrk3(jk)*abs(zci(inc)-umfc) *zcinc - vm_zflx_mode = flux_z(inc,jk) - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) +(vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - endif - enddo !waves inc=1,nwav - - ze1 =fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 -! -------------- - enddo ! end Azimuth do-loop - -! -! extra- eddy wave dissipation to limit GW-rms -! tx1 = sum(abs(dfdz_v(jk,1:nazd)))/bn2(jk) -! ze1=max(dked_min, tx1) -! ze2=min(dked_max, ze1) -! vueff(jkp) = ze2 + vueff(jkp) -! - - - enddo ! end Vertical do-loop -! -! top-layers constant interface-fluxes and zero-heat -! - fpu(1:nazd,ktop) = fpu(1:nazd, levs) - dfdz_v(1:nazd, levs) = 0.0 - -! --------------------------------------------------------------------- -! sum contribution for total zonal and meridional fluxes + -! energy dissipation -! --------------------------------------------------- -! -!======================================================================== -! at the source level and below taux = 0 (taux_E=-taux_W by assumption) -!======================================================================== - - - - do jk=ksrc, levs - taux(jk) = 0.0 - tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk)+ dfdz_v(iaz,jk) - enddo - enddo - jk = ktop; taux(jk)=0.; tauy(jk)=0. - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - enddo - - if (idebug_gwrms == 1) then - - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - - endif -! - - do jk=ksrc,levs - jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp - ze2 = (tauy(jkp)-tauy(jk))* zdelp - - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - pdudt(jl,jk) = -ze1 - pdvdt(jl,jk) = -ze2 -! -! Cx =0 based Cx=/= 0. above -! -! - if (knob_ugwp_doheat == 1) then -! -! ek1 =aum(jk)*aum(jk) +avm(jk)*avm(jk) -! ugw = aum(jk)- ze1*dtp; vgw = avm(jk)- ze2*dtp -! ek2 = ugw*ugw +vgw*vgw -! pdtdt(jl,jk) = rdtp2*max(ek1-ek2, 0.0) !=ze1*um + 0.5*ze1^2*dtp -! pdtdt(jl,jk) = max(ze1*aum(jk) + ze2*avm(jk), 0.) ! gw_eff => in "ze1 and ze2" - pdtdt(jl,jk) = max(pdtdt(jl,jk) , 0.)*gw_eff - endif - - if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt - ze1 = max(dked_min, pdtdt(jl,jk)/bn2(jk)) - dked(jl,jk) = min(dked_max, ze1) - - enddo -! -! add limiters/efficiency for "unbalanced ics" if it is needed -! - do jk=ksrc,levs - pdtdt(jl,jk) = pdtdt(jl,jk)*rcpd - enddo -! - dktur(1:levs) = dked(jl,1:levs) -! - do ist= 1, 3 - do jk=ksrc,levs-1 - adif(jk) = .25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - -! dked(jl, ksrc:levs-1) = dktur(ksrc:levs-1) -! dked(jl, levs) =dked(jl, levs-1) - -! -! perform "diffusive" 3-point smoothing of "u-v-t" -! from the surface to the "top" -! - if (knob_ugwp_dokdis == 2) then - - uold(1:levs) = aum(1:levs)+pdudt(jl,1:levs)*dtp - vold(1:levs) = avm(1:levs)+pdvdt(jl,1:levs)*dtp - told(1:levs) = atm(1:levs)+pdtdt(jl,1:levs)*dtp - - do jk=1,levs - zmetk= azmet(jk)*rhp - ktur = kvg(k) + 2.e-5*exp( zmetk) - dktur(jk) = dked(jl,jk) + ktur - enddo - - dzmetm= azmet(ksrc)- azmet(ksrc-1) - - do jk=2,levs-1 - dzmetf = (azmeti(jk+1)- azmeti(jk))*rhomid(jk) - ktur = .5*(dktur(jk-1)+dktur(jk)) *rhoint(jk)/dzmetf - kturp = .5*(dktur(jk+1)+dktur(jk))*rhoint(jk+1)/dzmetf - - dzmetp = azmet(jk+1)-azmet(jk) - Adif(jk) = ktur/dzmetm - Cdif(jk) = kturp/dzmetp - bdif = adif(jk)+cdif(jk) - if (rdtp < bdif ) then - Anstab(jk) = nint( bdif/rdtp + 1) - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - if (nstab .ge. 2) print *, 'nstab ', nstab - dtdif = dtp/real(nstab) - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = nstab*rdtp-Adif(k)-Cdif(k) - unew(k) = uold(k)*Bdif+ uold(k-1)*Adif(k) + uold(k)*Cdif(k) - vnew(k) = vold(k)*Bdif+ vold(k-1)*Adif(k) + vold(k)*Cdif(k) - tnew(k) = told(k)*Bdif+ told(k-1)*Adif(k) + told(k)*Cdif(k) - enddo - uold = unew*dtdif - vold = vnew*dtdif - told = tnew*dtdif - enddo -! -! create "smoothed" tendencies by molecular + GW-eddy diffusion -! - do k=ksrc,levs-1 - pdtdt(jl,jk)= rdtp*(told(k) - tm(jl,k)) - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - if (abs(pdtdt(jl,jk)) >= maxdtdt ) pdtdt(jl,jk) = maxdtdt - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 -! -! add eddy viscosity heating -! pdtdt(jl,jk) = pdtdt(jl,jk) - max(ze1*aum(jk) + ze2*avm(jk), 0.) *rcpd -! - enddo - - - ENDIF ! dissipative IF-loop for "abrupt" tendencies - - enddo ! J-loop -! - - - RETURN - -! -! Print/Debugging ----------------------------------------------------------------------- -! - 239 continue - if (kdt ==1 .and. mpi_id == master) then -! - print *, 'ugwp-vay: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwp-vay: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwp-vay: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwp-vay: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - - print * - - endif - - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' -! -! print *, ' ugwp -heating rates ' - endif - - - - return - end subroutine cires_ugwp_solv2_v1 - - -end module cires_ugwp_solv2_v1_mod diff --git a/physics/cires_ugwp_solvers.F90 b/physics/cires_ugwp_solvers.F90 deleted file mode 100644 index 6736daf6a..000000000 --- a/physics/cires_ugwp_solvers.F90 +++ /dev/null @@ -1,664 +0,0 @@ -! GW SOLVERS: -!=========== SOLVER_ORODIS; SOLVER_WMSDIS, SOLVER_LSATDIS -! + RF_DAMP if it is needed along with ugwp_tofd -!=========== -! Note in contrast to dycore vertical indices: surface=1 top=levs -! -! Collection of main friction-GWD solvers -! -! subroutine ugwp_oro -! -! subroutine gw_solver_linsatdis -! subroutine gw_solver_wmsdis -! subroutine rf_damp -! -! =========== -! -! - subroutine ugwp_oro(im, levs, dtp, kdt,me, lprnt, fcor, c2f2, & - u, v, tkin, pint, delp, pmid, pexner, gzint, gzmid, orostat, & - hpbl, axz, ayz, edis, kdis, dusfc, dvsfc, & - dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, dusfc_lwb, dvsfc_lwb, & - zmtb, zlwb, zogw, tauf_ogw, tauz_ogw, axmtb, axlwb, axtms ) -!---------------------------------------------------------------------- -! COORDE-output: 6-hour inst: U, V, T, PMSL, PS, HT (ounce) -! 3D 6-hr aver: DYN-U, SSO-U, PBL-U, AF-U1.... -! 2D 6-hr aver: tau_SSO, tau_GWD, tau_BL; & -! tau_sso = tau_mtb + tau_tofd + tau_lwb +tau_ogw -! ZM 6-hr aver: tau_RES = PS*dH/dx -zonal mean -! Experiments: Midlat 80-200km -! LR_CTL; ; LR_NOSSO with TOFD/TMS; -! LR_NOGWD (MTN+TOFD); LR_GWD4 --- 4 times taub -!---------------------------------------------------------------------- - use machine , only : kind_phys - use ugwp_oro_init, only : cdmb, cleff, sigfac, hncrit, hpmin, hminmt - use ugwp_oro_init, only : gamm_std, sigma_std - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - - - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - - implicit none - logical :: lprnt - integer :: im, levs - integer :: me - integer :: kdt - real(kind_phys) :: dtp - real(kind_phys), dimension(im) :: hpbl ! pbl-height in meters - real(kind_phys), dimension(im) :: fcor, c2f2 - real(kind_phys), dimension(im, 14) :: orostat - real(kind_phys), dimension(im, levs) :: u, v, tkin, q - - real(kind_phys), dimension(im, levs) :: pmid, pexner, gzmid, delp - real(kind_phys), dimension(im, levs+1) :: pint, gzint - - - real(kind_phys), dimension(im, levs) :: axz, ayz, edis, kdis ! total 6-hr averaged tendencies - real(kind_phys), dimension(im, levs) :: krf2d - real(kind_phys), dimension(im, levs) :: tauz_ogw, axmtb, axlwb, axtms ! 3-sub components axogw = axz-(axmtb+axlwb+axtms) - real(kind_phys), dimension(im) :: tauf_ogw ! total-source momentum flux - - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw - - real(kind_phys), dimension(im) :: dusfc, dvsfc ! total tausfc_sso - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb ! integrated tau_mtb - real(kind_phys), dimension(im) :: dusfc_ogw, dvsfc_ogw ! integrated tau_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb ! integrated tau_lwb - real(kind_phys), dimension(im) :: dusfc_tofd, dvsfc_tofd ! integrated tau_tofd - -! -! mu=hprime gamm=a/b sigma theta -! which stand for the standard deviation, the anisotropy, the slope and the orientation of the orography. -! - real(kind_phys) :: elvmax(im) - real(kind_phys) :: hprime(im) - - real(kind_phys) :: theta !the orienatation, angle - real(kind_phys) :: sigma !the slope dh/dx - real(kind_phys) :: gamm !the anisotropy see ifs-oro - - real(kind_phys) :: oc, oa4(4), clx4(4) !kim & doyle 2005 .... attempt to do TOFD ..? -! - integer, allocatable :: k_elev(:), k_mtb(:), k_ogw(:), k_lee(:), k_tofd(:) - - real(kind_phys) wk(im) - - real(kind_phys) eng0, eng1 -! -! -! - real(kind_phys), dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid1, pex - - real(kind_phys), dimension(levs+1) :: taudz, rhoi, rim_z, pint1, zpi - real(kind_phys), dimension(levs) :: drtau, kdis_oro -! - real (kind_phys) :: elvp, elvpd, dtaux, dtauy - real(kind_phys) :: loss, mtb_fric, mbx, mby - real(kind_phys) :: sigflt - - real(kind_phys) :: zpbl = 2000. ! can be passed from PBL physics as in gwdps.f -! - logical icrilv(im) -! -!---- mountain/oro gravity wave drag +TOFD -! - real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1, epstofd1, krf_tofd1 -! - real(kind=kind_phys), dimension(levs) :: drlee, drmtb, drlow, drogw - real(kind_phys) :: r_cpdt, acc_lim - real(kind_phys), dimension(im) :: tautot, tauogw, taumtb, taulee, taurf - real(kind_phys) :: xn, yn, umag, kxridge, & - tx1, tx2 - real(kind=kind_phys),dimension(levs+1):: tau_src - - integer :: npt, krefj, kdswj, kotr, i, j, k - integer :: ipt(im) - -! -! copy 1D -! - do i=1, im - hprime(i) = orostat(i, 1) - elvmax(i) = orostat(i, 14) -! - tautot(i) = 0.0 - tauogw(i) = 0.0 - taumtb(i) = 0.0 - taulee(i) = 0.0 - taurf(i) = 0.0 -! - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - dusfc_mb(i) = 0.0 - dvsfc_mb(i) = 0.0 - dusfc_ogw(i) = 0.0 - dvsfc_ogw(i) = 0.0 - dusfc_lwb(i) = 0.0 - dvsfc_lwb(i) = 0.0 - dusfc_tofd(i) = 0.0 - dvsfc_tofd(i) = 0.0 - tauf_ogw(i) = 0.0 -! - zmtb(i) = -99. - zlwb(i) = -99. - zogw(i) = -99. - ipt(i) = 0 - enddo -! print *, maxval(hprime), maxval(elvmax), ' check hprime -elevmax ugwp_oro' -! -! 3-part of oro-effects + ked_oro -! - do k=1, levs - do i=1, im - axz(i,k) = 0.0 - ayz(i,k) = 0.0 - edis(i,k) = 0.0 - kdis(i,k) = 0.0 - krf2d(i,k) = 0.0 - tauz_ogw(i,k) = 0.0 - axmtb(i:,k) = 0.0 - axlwb(i,k) = 0.0 - axtms(i,k) = 0.0 - enddo - enddo - -! -! optional diag 3-parts of drag: [tx_ogw, tx_mtb, tx_lee] -! -! ----do we have orography for mtb and gwd calculation points ? -! - npt = 0 - do i = 1,im - if ( (elvmax(i) > hminmt) .and. (hprime(i) > hpmin) ) then - npt = npt + 1 - ipt(npt) = i - - endif - enddo - if (npt == 0) return ! no ororgraphy ====> gwd/mb calculation done - -! allocate(iwklm(npt), idxzb(npt), kreflm(npt)) - allocate( k_elev(npt), k_mtb(npt), k_ogw(npt), k_lee(npt), k_tofd(npt)) - do i=1,npt - k_ogw (i) = 2 - k_tofd(i) = 2 - k_lee (i) = 2 - k_mtb(i) = 0 - k_elev(i) = 2 - enddo -! -! controls through: use ugwp_oro_init -! main ORO-loop sigfac = n*sigma = [1.5, 2, 2.5, 4]*hprime -! - - - do i = 1, npt -! - j = ipt(i) - - elvpd = elvmax(j) - elvp = min (elvpd + sigfac * hprime(j), hncrit) - - sigma = orostat(j,13) - gamm = orostat(j,12) - theta = orostat(j,11)*deg_to_rad - - if (sigma == 0.0 ) then - sigma = sigma_std - gamm = gamm_std - theta = 0.0 - endif - - oc = orostat(j,2) - oa4(1) = orostat(j,3) - oa4(2) = orostat(j,4) - oa4(3) = orostat(j,5) - oa4(4) = orostat(j,6) - clx4(1) = orostat(j,7) - clx4(2) = orostat(j,8) - clx4(3) = orostat(j,9) - clx4(4) = orostat(j,10) -! -! do column-based diagnostics "more-efficient" for oro-places -! - - do k=1,levs - up(k) = u(j,k) - vp(k) = v(j,k) - tp(k) = tkin(j,k) - qp(k) = q(j,k) - dp(k) = delp(j,k) - - zpm(k) = gzmid(j,k) * rgrav - pmid1(k) = pmid(j,k) - pex(k) = pexner(j,k) - enddo - do k=1,levs+1 - zpi(k) = gzint(j,k) * rgrav - pint1(k) = pint(j,k) - enddo -! -! elvp- k-index: iwklm k_elvp = index for elvmax + 4*hprime, "elevation index" -! GFS-2017 - do k=1, levs-1 - if (elvp <= zpi(k+1) .and. elvp > zpi(k)) then - k_elev(i) = k+1 !......simply k+1 next interface level - exit - endif - enddo -! if (elvp .ge. 300. ) then -! write(6,333) elvp, zpi(1), elvpd, hprime(j), sigfac, hncrit -! pause -! endif -!333 format(6(3x, F10.3)) -! -! SSO effects: TOFD-drag/friction coefficients can be calculated -! - sigflt = hprime(j)*0.01 ! turb SSo(j) ...small-scale orography < 2-5 km .... - zpbl = hpbl(j) - - call ugwp_tofd1d(levs, sigflt, elvPd, zpi(1), zpbl, up, vp, zpm, & - utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1, levs - krf2d(j,k) = krf_tofd1(k) - axtms(j,k) = utofd1(k) -!------- -! nullify ORO-tendencies -! - drmtb(k) = 0.0 - drlee(k) = 0.0 - drtau(k) = 0.0 - drlow(k) = 0.0 - enddo - -!------- -! -! levels of k_mtb(i)/mtb + kdswj/dwlee + krefj/ogwd inside next "subs" -! zmtb, zlwb, zogw -! drmtb, drlow/drlee, drogw -!------- -! -! mtb : drmtb => 1-st order friction as well as TurbulentOro-Drag -! - call ugwp_drag_mtb( k_elev(i), levs, & - elvpd, elvp, hprime(j), sigma, theta, oc, oa4, clx4, gamm, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, k_mtb(i), drmtb, taumtb(j)) - - axmtb(j,1:levs) = drmtb(1:levs)*up(1:levs) -! -! print * , k_elev(i), k_mtb(i) , taumtb(j)*1.e3, ' k_elev, k_mtb , taumtb ' -! -! tautot = taulee+tauogw + rho*drlee = -d[taulee(z)]/dz -! - - - call ugwp_taub_oro(levs, k_mtb(i), kxw, taumtb(j), fcor(j), & - hprime(j) , sigma, theta, oc, oa4, clx4, gamm, elvp, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, xn, yn, umag, & - tautot(j), tauogw(j), taulee(j), drlee, tau_src, & - kxridge, kdswj, krefj, kotr) - -! print *, k_mtb(i), kxw, taumtb(j), fcor(j),hprime(j), ' af ugwp_taub_oro ' -! print *, kdswj, krefj, kotr, ' kdswj, krefj, kotr ' - - - tauf_ogw(j) = tautot(j) - axlwb(j,1:levs) = drlee(1:levs) - - if ( k_mtb(i) > 0) zmtb(j) = zpi(k_mtb(i))- zpi(1) - if ( krefj > 0) zogw(j) = zpi(krefj) - zpi(1) - if ( kdswj > 0) zlwb(j) = zpi(kdswj) - zpi(1) -! if ( k_mtb(i) > 0 .and. zmtb(j) > zogw(j)) print *, ' zmtb > zogw ', zmtb(j), zogw(j) -! -! tau: tauogw, kxw/kxridge ATTENTION c2f2(j) = fcor(j)*fcor(j)/kxridge/kxridge -! - if ( (krefj > 1) .and. ( abs(tauogw(j)) > 0.) ) then -! - call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & - fcor(j), kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & - xn, yn, umag, drtau, kdis_oro) -! - else - drtau = 0. - endif - - tauz_ogw(j,1:levs) = tau_src(1:levs) - - r_cpdt = rcpd2/dtp -! -! - do k = 1,levs -! -! project to x-dir & y=dir and do diagnostics -! & apply limiters and output separate oro-effects -! - drlow(k) = drtau(k) + drlee(k) - acc_lim = min(abs(drlow(k)), max_axyz) - drlow(k) = sign(acc_lim, drlow(k)) - - dtaux = drlow(k) * xn + utofd1(k) - dtauy = drlow(k) * yn + vtofd1(k) - - eng0 = up(k)*up(k)+vp(k)*vp(k) - eng1 = 0.0 -! - if (k < k_mtb(i) .and. drmtb(k) /= 0 ) then - loss = 1.0 / (1.0+drmtb(k)*dtp) - mtb_fric = drmtb(k)*loss -! - mbx = mtb_fric * up(k) - mby = mtb_fric * vp(k) -! - ayz(j,k) = -mby !+ ayz(j,k) - axz(j,k) = -mbx !+ axz(j,k) -! - eng1 = eng0*loss*loss +eng1 - dusfc(j) = dusfc(j) - mbx * dp(k) - dvsfc(j) = dvsfc(j) - mby * dp(k) - endif -! - ayz(j,k) = dtauy + ayz(j,k) - axz(j,k) = dtaux + axz(j,k) -! - tx1 = u(j,k) + dtaux*dtp - tx2 = v(j,k) + dtauy*dtp - eng1 = tx1*tx1 + tx2*tx2 + eng1 - - dusfc(j) = dusfc(j) + dtaux * dp(k) - dvsfc(j) = dvsfc(j) + dtauy * dp(k) - - edis(j,k) = max(eng0-eng1, 0.0) * r_cpdt !+ epstofd1(k) - kdis(j,k) = min(kdis_oro(k), max_kdis ) - - enddo -! - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) -! -! oro-locations -! - enddo ! ipt - oro-loop .... "fraction of Land" in the grid box - deallocate(k_elev, k_mtb, k_ogw, k_lee, k_tofd ) -! - end subroutine ugwp_oro -! -! - subroutine gw_solver_linsatdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs - integer :: me, kdt, nw, naz, nf_src - real :: dtp - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, & - q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, & - bn2i, bvi, rhoi - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real, dimension(levs+1) :: ked1, tau1 - real :: chm, ss - real, parameter :: dsp = 1./20. - logical :: pfirst=.true. - - save pfirst -128 Format (2x, I4, 4(2x, F10.3)) - -! do i=1, nw -! spf(i) = exp(-Ch(i)*dsp) -! enddo -! ss = sum(spf) -! spf(1:nw) = spf(1:nw)/ss - - if (pfirst ) then - j = 1 - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j) - print * - chm = 0. - do i=1, nw - write(6, 128) i, spf(i), taub_spect(i)*1.e3, ch(i), ch(i)-chm - chm = ch(i) - enddo - - print * - !pause - endif - - do j=1,im - if (if_src(j) == 1) then -! -! compute GW-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! H2O-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) * rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k) * rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j)/rhoi(ksrc) - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' tempi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(u1), minval(u1) , ' ++++ u1 ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(v1), minval(v1) , ' ++++ v1 ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! - call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, & - ch, xaz, yaz, fcor(j), c2f2(j), dp, & - zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, & - ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' rhoi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(pint), minval(pint) , ' pint ' - !pause - endif -! -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - endif - - enddo - pfirst = .false. -! -! spectral solver for discrete spectra of GWs in N-azimiths -! Linear saturation with background dissipation -! - end subroutine gw_solver_linsatdis -! - subroutine gw_solver_wmsdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) -! use para_taub, only : tau_ex - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs, me, kdt, nw, naz, nf_src - real :: dtp - - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real,dimension(levs+1) :: ked1, tau1 - real :: tau_ex - -! print *, nf_src, 'nf_src ... gw_solver_wmsdis ' -! print *, if_src, 'if_src ... gw_solver_wmsdis ' - - do j=1,im - if (if_src(j) == 1) then -! -! compute gw-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! h2o-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) *rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k)*rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! -! any extras bkg-arrays -! - ksrc = klev(j) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! more work for spectral setup for different "slopes" -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tau_ex = taub(j) - taub_spect(1:nw) = spf(1:nw)/rhoi(ksrc) *tau_ex ! check it ....*tau_ex(j) - -! -! call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) -! -! print *, ' bf ugwp_wmsdis_naz ksrc', ksrc, zmid(ksrc) - - call ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, tau_ex, ch, xaz, yaz, & - fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, & - rho, ui, vi, ti, kvg, ktg, krad, kion, bn2i, bvi, & - rhoi, ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - -! print *, ' after ugwp_wmsdis_naz ksrc', ksrc, zint(ksrc) - -! subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & -! fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked) - -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - - endif - - enddo -! -! ugwp_wmsdis_naz everything similar to linsat , except spectral saturation -! -! - return - end subroutine gw_solver_wmsdis -! -! - subroutine rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, u, v, ax, ay, eps) - use ugwp_common, only : rcpd2 - - implicit none - - integer :: im, levs, levs_rf - real :: dtp - real, dimension(levs) :: rfdis, rfdist - real, dimension(im, levs) :: u, v, ax, ay, eps - real :: ud, vd, rdtp - integer :: i, k - - rdtp = 1.0 / dtp - - do k= levs_rf, levs - do i=1,im - ud = rfdis(k)*u(i,k) - vd = rfdis(k)*u(i,k) - ax(i,k) = rfdist(k)*u(i,k) - ay(i,k) = rfdist(k)*v(i,k) - eps(i,k) = rcpd2*(u(i,k)*u(i,k) +v(i,k)*v(i,k) -ud*ud -vd*vd) - enddo - enddo - end subroutine rf_damp -! diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index c345a8e85..4a8b97590 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -1,473 +1,5 @@ - subroutine ugwp_triggers - implicit none - write(6,*) ' physics-based triggers for UGWP ' - end subroutine ugwp_triggers -! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - use ugwp_common , only : deg_to_rad - - implicit none - integer :: nx, ny - real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: earth_r, ra1, ra2, dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - integer :: j -! -! specify common constants and -! geometric factors to compute deriv-es etc ... -! coriolis coslat tan etc... -! - earth_r = 6370.e3 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 -! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) -! - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo -! - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos -! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) - - dlat = ra1 / (dy+dy) - - divJp = dlat*cosv - divJM = dlat*cosv -! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) -! - return - end SUBROUTINE subs_diag_geo -! - subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! compute for each Vert-column: grad(V) -! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Vx(nx, ny), Vy(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) - - end subroutine get_xy_pt - - subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) -! -! compute for each Vert-column: grad(V) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Divjp(ny), Divjm(ny) - real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) -!~~~~~~~~~~~~~~~~~~~~ -! 1/cos*d(vcos)/dy -!~~~~~~~~~~~~~~~~~~~~ - do j=2, ny-1 - Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) - enddo - Vyd(:, 1) = Vyd(:,2) - Vyd(:,ny) = Vyd(:,ny-1) - - end subroutine get_xyd_wind - - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_fgf -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - - enddo - end subroutine trig3d_fjets - - subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_okw -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2, d1 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 - W2 = (Vx - Uyd)*(Vx - Uyd) - D1 = Ux + Vyd - trig3d_okw(:,:,k) = W1 -W2 -! trig3d_okw(:, :, k) =S2 -W2 -! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean -! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk - enddo - end subroutine trig3d_okubo -! - subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_conv - - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - integer :: k - end subroutine trig3d_dconv - - subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & - U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - trig3d_okw, trig3d_fgf, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! -! reversed ??? Hyai, Hybi , pmid -! - real, dimension(nz+2) :: Hyai, Hybi - real, dimension(nz+1) :: Hyam, Hybm -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS, HS - real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - real :: dzkm, zkm - integer :: k -!================================================================================== -! fgf and OW-triggers -! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! -! -!=================================================================================== - - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) - call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) -!===================================================================================================== -! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d -! -! Bulk momentum flux=/ 0 and levels for launches -! -!===================================================================================================== - 111 format(i6, 4(3x, F8.3), ' trigger-grid ') - - do k=1, nz-1 - zkm = -7.*alog(pmid(k)*1.e-3) - dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) - write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' - enddo - - end subroutine cires_3d_triggers -!================================================================================== -! tot-flux launch 0 or 1 # of Launches -! specify time-dep bulk sources: taub, klev, if_src, nf_src -! -!================================================================================== - subroutine get_spectra_tau_convgw & - (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) ! -! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function -! - integer :: nw, im, levs - integer,dimension(im,3) :: icld - real, dimension(im, levs) :: dcheat, scheat - real, dimension(im) :: precip, xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! -! locals - real, parameter :: precip_max = 100. ! mm/day - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - - integer :: i, k, klow, ktop, kmid - real :: dtot, dmax, daver -! - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - do i=1, im - klow = icld(i,1) - ktop = icld(i,2) - kmid= icld(i,3) - if (klow == -99 .and. ktop == -99) then - cycle - else - klev(i) = ktop - k = klow - klev(i) = k - dmax = abs(dcheat(i,k) + scheat(i,k)) - do k=klow+1, ktop - dtot =abs(dcheat(i,k) + scheat(i,k)) - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! -! klev as max( dcheat(i,k) + scheat) -! vertical width of conv-heating -! -! counts/triiger=1 & taub(i) -! - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_amp* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! 100 mb launch and MERRA-2 slat-forcing -! - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo - -! with info on precip/clouds/dc_heat create Bulk -! taub(im), klev(im) -! -! print *, ' get_spectra_tau_convgw ' - end subroutine get_spectra_tau_convgw -! - subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_fgf -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1.0 / float(kwidth) - tau_min = tau_amp*fnorm - do i=1, im -! -! only trop-c fjets so find max(trig_fgf) => klev -! use abs-values to scale tau_amp -! - - k = klow - klev(i) = k - dmax = abs(trig_fgf(i,k)) - kex = 0 - if (dmax >= tlim_fgf) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_fgf(i,k)) - if (dtot >= tlim_fgf) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo - - if (dmax .ge. tlim_fgf) then - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! print *, ' get_spectra_tau_nstgw ' - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo -! - end subroutine get_spectra_tau_nstgw -! - subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_okw -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1./float(kwidth) - tau_min = tau_amp*fnorm - print *, ' get_spectra_tau_okwgw ' - do i=1, im - k = klow - klev(i) = k - dmax = abs(trig_okw(i,k)) - kex = 0 - if (dmax >= tlim_okw) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! - if (dmax >= tlim_okw) then - nf_src = nf_src + 1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo - print *, ' get_spectra_tau_okwgw ' - end subroutine get_spectra_tau_okw -! -! -! -!>\ingroup cires_ugwp_run -!> @{ -!! -!! - subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) + subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -498,9 +30,9 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5_tamp + end subroutine slat_geos5_tamp_v0 - subroutine slat_geos5(im, xlatdeg, tau_gw) + subroutine slat_geos5_v0(im, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= @@ -537,9 +69,10 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) tau_gw(i) = tau_amp*flat_gw enddo ! - end subroutine slat_geos5 - subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common , only : pi2 + end subroutine slat_geos5_v0 +! + subroutine init_nazdir_v0(naz, xaz, yaz) + use ugwp_common_v0 , only : pi2 implicit none integer :: naz real, dimension(naz) :: xaz, yaz @@ -563,4 +96,4 @@ subroutine init_nazdir(naz, xaz, yaz) xaz(4) = 0.0 yaz(4) =-1.0 !S endif - end subroutine init_nazdir + end subroutine init_nazdir_v0 diff --git a/physics/cires_ugwp_triggers_v1.F90 b/physics/cires_ugwp_triggers_v1.F90 deleted file mode 100644 index 8cfd57cb7..000000000 --- a/physics/cires_ugwp_triggers_v1.F90 +++ /dev/null @@ -1,584 +0,0 @@ -module cires_ugwp_triggers_v1 - - -contains - - - subroutine ugwp_triggers - implicit none - write(6,*) ' physics-based triggers for UGWP ' - end subroutine ugwp_triggers -! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, earth_r, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - implicit none - integer :: nx, ny - real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: ra1, ra2, dx, dy, dlat - real :: con_pi, earth_r - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - integer :: j - real :: deg_to_rad -! -! specify common constants and -! geometric factors to compute deriv-es etc ... -! coriolis coslat tan etc... -! - deg_to_rad = con_pi/180.0 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 -! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) -! - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo -! - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos -! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) - - dlat = ra1 / (dy+dy) - - divJp = dlat*cosv - divJM = dlat*cosv -! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) -! - return - end SUBROUTINE subs_diag_geo -! - subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! compute for each Vert-column: grad(V) -! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Vx(nx, ny), Vy(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) - - end subroutine get_xy_pt - - subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) -! -! compute for each Vert-column: grad(V) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Divjp(ny), Divjm(ny) - real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) -!~~~~~~~~~~~~~~~~~~~~ -! 1/cos*d(vcos)/dy -!~~~~~~~~~~~~~~~~~~~~ - do j=2, ny-1 - Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) - enddo - Vyd(:, 1) = Vyd(:,2) - Vyd(:,ny) = Vyd(:,ny-1) - - end subroutine get_xyd_wind - - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & - con_pi, con_rerth, pmid, trig3d_fgf) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_fgf -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - - enddo - end subroutine trig3d_fjets - - subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_okw -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2, d1 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, con_pi, con_rerth, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 - W2 = (Vx - Uyd)*(Vx - Uyd) - D1 = Ux + Vyd - trig3d_okw(:,:,k) = W1 -W2 -! trig3d_okw(:, :, k) =S2 -W2 -! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean -! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk - enddo - end subroutine trig3d_okubo -! - subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_conv - - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - integer :: k - end subroutine trig3d_dconv - - subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & - U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - con_pi, con_rerth, trig3d_okw, trig3d_fgf, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) - real :: con_pi, con_rerth -! -! reversed ??? Hyai, Hybi , pmid -! - real, dimension(nz+2) :: Hyai, Hybi - real, dimension(nz+1) :: Hyam, Hybm -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS, HS - real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - real :: dzkm, zkm - integer :: k -!================================================================================== -! fgf and OW-triggers -! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! -! -!=================================================================================== - - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, & - con_pi, con_rerth, pmid, trig3d_fgf) - call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) - call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) -!===================================================================================================== -! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d -! -! Bulk momentum flux=/ 0 and levels for launches -! -!===================================================================================================== - 111 format(i6, 4(3x, F8.3), ' trigger-grid ') - - do k=1, nz-1 - zkm = -7.*alog(pmid(k)*1.e-3) - dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) - write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' - enddo - - end subroutine cires_3d_triggers -!================================================================================== -! tot-flux launch 0 or 1 # of Launches -! specify time-dep bulk sources: taub, klev, if_src, nf_src -! -!================================================================================== - subroutine get_spectra_tau_convgw & - (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) -! -! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function -! - integer :: nw, im, levs - integer,dimension(im,3) :: icld - real, dimension(im, levs) :: dcheat, scheat - real, dimension(im) :: precip, xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! -! locals - real, parameter :: precip_max = 100. ! mm/day - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - - integer :: i, k, klow, ktop, kmid - real :: dtot, dmax, daver -! - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - do i=1, im - klow = icld(i,1) - ktop = icld(i,2) - kmid= icld(i,3) - if (klow == -99 .and. ktop == -99) then - cycle - else - klev(i) = ktop - k = klow - klev(i) = k - dmax = abs(dcheat(i,k) + scheat(i,k)) - do k=klow+1, ktop - dtot =abs(dcheat(i,k) + scheat(i,k)) - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! -! klev as max( dcheat(i,k) + scheat) -! vertical width of conv-heating -! -! counts/triiger=1 & taub(i) -! - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_amp* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! 100 mb launch and MERRA-2 slat-forcing -! - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo - -! with info on precip/clouds/dc_heat create Bulk -! taub(im), klev(im) -! -! print *, ' get_spectra_tau_convgw ' - end subroutine get_spectra_tau_convgw -! - subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_fgf -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1.0 / float(kwidth) - tau_min = tau_amp*fnorm - do i=1, im -! -! only trop-c fjets so find max(trig_fgf) => klev -! use abs-values to scale tau_amp -! - - k = klow - klev(i) = k - dmax = abs(trig_fgf(i,k)) - kex = 0 - if (dmax >= tlim_fgf) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_fgf(i,k)) - if (dtot >= tlim_fgf) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo - - if (dmax .ge. tlim_fgf) then - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! print *, ' get_spectra_tau_nstgw ' - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo -! - end subroutine get_spectra_tau_nstgw -! - subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_okw -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1./float(kwidth) - tau_min = tau_amp*fnorm - print *, ' get_spectra_tau_okwgw ' - do i=1, im - k = klow - klev(i) = k - dmax = abs(trig_okw(i,k)) - kex = 0 - if (dmax >= tlim_okw) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! - if (dmax >= tlim_okw) then - nf_src = nf_src + 1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo - print *, ' get_spectra_tau_okwgw ' - end subroutine get_spectra_tau_okw -! -! -! -!>\ingroup cires_ugwp_run -!> @{ -!! -!! - subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: tau_amp, xlatdeg(im), tau_gw(im) - real :: latdeg, flat_gw, tem - integer :: i - -! -! if-lat -! - do i=1, im - latdeg = abs(xlatdeg(i)) - if (latdeg < 15.3) then - tem = (latdeg-3.0) / 8.0 - flat_gw = 0.75 * exp(-tem * tem) - if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 - elseif (latdeg < 31.0 .and. latdeg >= 15.3) then - flat_gw = 0.10 - elseif (latdeg < 60.0 .and. latdeg >= 31.0) then - tem = (latdeg-60.0) / 23.0 - flat_gw = 0.50 * exp(- tem * tem) - elseif (latdeg >= 60.0) then - tem = (latdeg-60.0) / 70.0 - flat_gw = 0.50 * exp(- tem * tem) - endif - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5_tamp_v1 - - subroutine slat_geos5(im, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: xlatdeg(im) - real :: tau_gw(im) - real :: latdeg - real, parameter :: tau_amp = 100.e-3 - real :: trop_gw, flat_gw - integer :: i -! -! if-lat -! - trop_gw = 0.75 - do i=1, im - latdeg = xlatdeg(i) - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) - if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then - flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5 - subroutine init_nazdir(con_pi, naz, xaz, yaz) - implicit none - real :: con_pi - integer :: naz - real, dimension(naz) :: xaz, yaz - integer :: idir - real :: phic, drad - real :: pi2 - pi2 = 2.0*con_pi - drad = pi2/float(naz) - if (naz.ne.4) then - do idir =1, naz - Phic = drad*(float(idir)-1.0) - xaz(idir) = cos(Phic) - yaz(idir) = sin(Phic) - enddo - else -! if (naz.eq.4) then - xaz(1) = 1.0 !E - yaz(1) = 0.0 - xaz(2) = 0.0 - yaz(2) = 1.0 !N - xaz(3) =-1.0 !W - yaz(3) = 0.0 - xaz(4) = 0.0 - yaz(4) =-1.0 !S - endif - end subroutine init_nazdir - - -end module cires_ugwp_triggers_v1 - diff --git a/physics/cires_ugwp_utils.F90 b/physics/cires_ugwp_utils.F90 deleted file mode 100644 index 63a5b3238..000000000 --- a/physics/cires_ugwp_utils.F90 +++ /dev/null @@ -1,152 +0,0 @@ -! - subroutine um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, bn2, uhm, vhm, bn2hm, rhohm) -! - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - implicit none -! -! mass-averaged variables between klow-ktop -! - integer, intent(in) :: nz, klow, ktop - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: pint, zpi - real, dimension(nz), intent(out) :: bn2 - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp, rhm,dphm - - real, intent(out) :: uhm, vhm, bn2hm, rhohm - - integer :: k -! - dphm = 0.0 !pint(k+1)-pint(k)) - - uhm = 0.0 ! dphm*u1(k) - vhm = 0.0 ! dphm*v1(k) - rhm = 0.0 ! - bn2hm = 0.0 ! -! - do k=klow, ktop - vtj = tp(k) * (1.+fv*qp(k)) - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rhok = rdi * pmid(k) / vtj ! density kg/m**3 - rdz = 1.0 / (zpm(k+1)-zpm(k)) -! dry -! bnv2 = grav * (rdz * ( tp(k+1)-tp(k)) +grcp) /tp(k) -! -! wet -! - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtk -! if (bnv2 < 0) print *, k, bnv2, ' bnv2 < 0 ', klow, ktop - bnv2 = max(bnv2, bnv2min ) - dzp = pint(k+1)-pint(k) - - dphm = dphm + dzp - uhm = uhm + up(k)*dzp - vhm = vhm + vp(k)*dzp - rhm = rhm + rhok*dzp - bn2hm = bn2hm + bnv2 * dzp - bn2(k) = bnv2 - enddo - - uhm = uhm/dphm - vhm = vhm/dphm - rhm = rhm/dphm - bn2hm = bn2hm/dphm - rhohm = rhm/dphm -! -! print *, ' MF-BV ', bn2hm, bn2(ktop), bn2(klow) -! - end subroutine um_flow -! -! - subroutine mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - - implicit none - - integer :: levs - real, dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(levs+1) :: pint, rho, zpi - real, dimension(levs) :: zdelpi, zdelpm - real :: zul, bvl - real, dimension(levs+1) :: ui, vi, bn2i, bvi, rhoi, ti, qi - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp - real :: vtji - integer :: k -! -! get interface values from surf to top -! - do k=2,levs - vi(k) = 0.5 *(vp(k-1) + vp(k)) - ui(k) = 0.5 *(up(k-1) + up(k)) - ti(k) = 0.5 *(tp(k-1) + tp(k)) - qi(k) = 0.5 *(qp(k-1) + qp(k)) - enddo - - k=1 - ti(k) = tp(k) - ui(k) = up(k) - vi(k) = vp(k) - qi(k) = qp(k) - k= levs - ti(k+1) = tp(k) - ui(k+1) = up(k) - vi(k+1) = vp(k) - qi(k+1)=qp(k) - - do k=1,levs-1 - vtj = tp(k) * (1.+fv*qp(k)) - vtji = ti(k) * (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj ! density kg/m**3 - rhoi(k) = rdi * pint(k) / vtji - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rdz = 1. / ( zpm(k+1)-zpm(k)) - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtji - bn2i(k) = max(bnv2, bnv2min ) - bvi(k) = sqrt( bn2i(k) ) - vtk = vtkp - enddo - k = levs - vtj = tp(k) ! * (1.+fv*qp(k)) - vtji = ti(k) !* (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj - rhoi(k) = rdi * pint(k) / vtji - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) - k = levs+1 - rhoi(k) = rdi * pint(k) / ti(k) - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) -! do k=1,levs -! write(6, 121) k, zpm(k)*1.e-3, zpi(k)*1.e-3, bvi(k), rho(k), rhoi(k) -! enddo - 121 format(i5, 2x, 3(2x, F10.3), 2(2x, E10.3)) - - end subroutine mflow_tauz - -! - subroutine get_unit_vector(u, v, u_n, v_n, mag) - implicit none - real, intent(in) :: u, v - real, intent(out) :: u_n, v_n, mag -! - - mag = sqrt(u*u + v*v) - - if (mag > 0.0) then - u_n = u/mag - v_n = v/mag - else - u_n = 0. - v_n = 0. - end if - - end subroutine get_unit_vector -! diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/cires_ugwpv1_triggers.F90 index 3c42e573b..838ead1ee 100644 --- a/physics/cires_ugwpv1_triggers.F90 +++ b/physics/cires_ugwpv1_triggers.F90 @@ -11,42 +11,6 @@ module cires_ugwpv1_triggers !> @{ !! !! - subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) -!================= -! V0: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real(kind=kind_phys) :: tau_amp, xlatdeg(im), tau_gw(im) - real(kind=kind_phys) :: latdeg, flat_gw, tem - integer :: i - -! -! if-lat -! - do i=1, im - latdeg = abs(xlatdeg(i)) - if (latdeg < 15.3) then - tem = (latdeg-3.0) / 8.0 - flat_gw = 0.75 * exp(-tem * tem) - if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 - elseif (latdeg < 31.0 .and. latdeg >= 15.3) then - flat_gw = 0.10 - elseif (latdeg < 60.0 .and. latdeg >= 31.0) then - tem = (latdeg-60.0) / 23.0 - flat_gw = 0.50 * exp(- tem * tem) - elseif (latdeg >= 60.0) then - tem = (latdeg-60.0) / 70.0 - flat_gw = 0.50 * exp(- tem * tem) - endif - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5_tamp_v0 -! - - -! subroutine slat_geos5_tamp_v1(im, tau_amp, xlatdeg, tau_gw) !================= ! V1: GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* diff --git a/physics/cires_vert_lsatdis.F90 b/physics/cires_vert_lsatdis.F90 deleted file mode 100644 index 362bed8ef..000000000 --- a/physics/cires_vert_lsatdis.F90 +++ /dev/null @@ -1,524 +0,0 @@ - subroutine ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & -! fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1) - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs, nw, naz, ksrc - real :: kxw - real, dimension(nw) :: taub_spect, ch - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - - real, dimension(levs+1 ) :: uaz - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - real, dimension(levs+1 ) :: taux, tauy - real, dimension(levs ) :: dzirho , dzpi - real :: usrc -! - integer :: iaz, k -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - - do k=1,levs - dzpi(k) = -(pint(k+1)-pint(k))/rho(k)*rgrav - dzirho(k) = 1./rho(k)/dzpi(k) ! grav/abs(dp(k)) still hydrostatic "UGWP" - enddo - - LOOP_IAZ: do iaz =1, naz - usrc = ui(ksrc)*xaz(iaz) +vi(ksrc)*yaz(iaz) - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) -usrc - enddo -! -! if (nw .le. 4) call stochastic ..ugwp_lsatdis_az1 only 4-waves ch_ngw1, fuw_ngw1, eff_ngw1=1 -! -! multi-wave scheme -! - if (nw .gt. 4) then - call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & - fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - endif -! - ENDDO LOOP_IAZ ! Azimuth of GW propagation directions -! -! sum over azimuth and project aTau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum(kedd(k,:)) - enddo - - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) -! -! end solver: gw_azimuth_solver_LS81 -! sign Ax in rho*dU/dt = -d(rho*tau)/dz -! [(k) - (k+1)] - ax =0. ; ay = 0. - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - return - -! - print * - print *, ' Ax: ', maxval(Ax(ksrc:levs))*86400., minval(Ax(ksrc:levs))*86400. - print *, ' Ay: ', maxval(Ay(ksrc:levs))*86400., minval(Ay(ksrc:levs))*86400. - print *, 'Eps: ', maxval(Eps(ksrc:levs))*86400., minval(Eps(ksrc:levs))*86400. - print *, 'Ked: ', maxval(Ked(ksrc:levs))*1., minval(Ked(ksrc:levs))*1. -! print *, 'Atau ', maxval(atau(ksrc:levs, 1:Naz))*1.e3, minval(atau(ksrc:levs, 1:Naz))*1.e3 -! print *, 'taux_gw: ', maxval(taux( ksrc:levs))*1.e3, minval(taux( ksrc:levs))*1.e3 - print * -!----------------------------------------------------------------------- -! Here we can apply "ad-hoc" or/and "stability-based" limiters on -! (axy_gw, ked_gw and eps_gw) and check vert-inegrated conservation laws: -! energy and momentum and after that => final update gw-phys tendencies -!----------------------------------------------------------------------- - - end subroutine ugwp_lsatdis_naz -! - subroutine ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_sp, & - fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) - -! call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & -! fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & -! kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - use cires_ugwp_module, only : F_coriol, F_nonhyd, F_kds, linsat, linsat2 - use cires_ugwp_module, only : iPr_ktgw, iPr_spgw, iPr_turb, iPr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! - implicit NONE -! - integer, intent(in) :: nw ! number of GW modes in given direction - integer, intent(in) :: levs ! vertical layers - integer, intent(in) :: ksrc ! level of GW-launch layer - - real , intent(in) :: kxw ! horizontal wavelength - real , intent(in) :: ch(nw) ! horizontal phase velocities - real , intent(in) :: taub_sp(nw) ! spectral distribution of the mom-flux -! - real, intent(in) :: fcor, c2f2 ! Corilois factors - - real , intent(in) :: um(levs+1) - real , intent(in) :: tm(levs+1) -!in - real, intent(in), dimension(levs) :: rho, zm - real, intent(in), dimension(levs+1) :: rhoi, zi - real, intent(in), dimension(levs+1) :: bn2, bn - real, intent(in), dimension(levs) :: dzpi, dzirho - real, intent(in), dimension(levs+1) :: kvg, ktg, krad, kion, kmol -!======================================================================== -!out - real, dimension(levs+1) :: tau, ked - real, dimension(levs) :: eps - -!========================================================================= -!local - real :: Fd1, Fd2 - real, dimension(levs) :: a_mkz - real, dimension(levs+1,nw) :: sp_tau, sp_ked, sp_kth - real, dimension(levs,nw) :: sp_eps - - real, dimension(levs,nw) :: sp_mkz, sp_etot - real, dimension(levs,nw) :: sp_ek, sp_ep - - - real, dimension(levs) :: swg_ep, swg_ek, swg_et, swg_kz - - real, dimension(nw) :: rtaus ! spectral distribution at ksrc - real :: sum_rtaus ! total flux in iaz-azimuth - real :: Chnorm, Cx, Cs, Cxs, Cx2sat - real :: Fdis, Fdisat - real :: Cdf2, Cdf1 ! (Cd*cd-f*f) and sqrt -! -! two-level => upward integration for wave-filtering (dissip + breaking) -! - real :: taus, tauk, tau_lin - real :: etws, etwk, etw_lin - real :: epss, epsk - real :: kds, kdk - real :: kzw, kzw2, kzw3, kzi, kzs - real :: wfd, wfi ! -! -! for GW dissipation on the rotational sphere -! - real :: Betadis ! Ep/Ek ratio - real :: BetaM, BetaT ! 0.5 or 1./1+b and 1-1/(1+b) - real :: wfdM, wfdT, wfiM, wfiT, wdop2 - - real :: dzi, keff, keff_m, keff_t, keffs - - real :: sf2k2, cf2 - real :: Lzkm, Lzsat - - integer :: i, k, igw - integer :: ksat1, ksat2 - - real :: zsat1, zsat2 - real :: kx2_nh - - real :: rab1, rab2, rab3, rab4, cd_ulim2 - - integer :: Ind_out(nw, levs+1) - -! - logical, parameter :: dbg_print = .false. -! -!=================================================================== -! Nullify arrays -! tau, eps, ked -!==================================================================== - - tau = 0.0 - eps = 0.0 - ked = 0.0 - Ind_out(1:nw,:) = 0 -! -! GW-spectral arrays ..... sp_etot ....sp_tau -! - sp_tau = 0. - sp_eps = 0. - sp_ked = 0. - sp_mkz = -99. - sp_etot = 0. - sp_ek = 0. - sp_ep = 0. - sp_kth = 0. -! - swg_et = 0. - swg_ep = 0. - swg_ek = 0. - swg_kz = 0. - cd_ulim2 = cd_ulim*cd_ulim - cf2 = F_coriol*c2f2 - kx2_nh = F_nonhyd*kxw*kxw - - if (dbg_print) then - write(6,*) linsat , ' eff-linsat & kx ', kxw - write(6,*) maxval(ch), minval(ch), ' ch ' - write(6,*) - write(6,*) maxval(rhoi), minval(rhoi), 'rhoi ' - write(6,*) zi(ksrc) , ' zi(ksrc) ' - write(6,*) cd_ulim, ' crit-level cd_ulim ' - write(6,*) F_coriol, ' F_coriol' - write(6,*) F_nonhyd, ' F_nonhyd ' - write(6,*) maxval(Bn), minval(BN), ' BN-BV ' - write(6,*) Um(ksrc), ' Um-ksrc ', cd_ulim2 , 'cd_ulim2 ', c2f2, ' c2f2 ' - !pause - endif - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Loop_GW: over GW-spectra -! of individual non-interactive modes -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - Loop_GW: do i=1, nw -! - Kds = 0.0 -! -! src-level -! - Cx = ch(i) - Um(ksrc) - Cdf2 = Cx*Cx - cf2 - taus = taub_sp(i) ! momentum flux for i-mode w/o rhoi(ksrc) - kzw = Bn(ksrc) / Ch(i) ! ch(i) > 0. Cx(i) < 0. critica - etws = taus*kzw / kxw - rtaus(i) = taus*rhoi(ksrc) -! - IF( Cx <= cd_ulim .or. Cdf2 <= cd_ulim2) THEN - Ind_out(i, ksrc) =-1 ! -1 - diagnostic index for critical levels - cycle Loop_GW ! got to the next mode of GW-spectra - ELSE -! - kzw2 = Bn2(ksrc)/Cdf2 - rhp4 - kx2_nh -! - if (kzw2 <= 0.) then - Ind_out(i, ksrc) =-2 ! -2 - diagnostic index for reflected waves - cycle Loop_GW ! no wave reflection in GW-LSD scheme - endif - - kzw = sqrt(kzw2) - kzw3 = kzw2*kzw - etws = taus*kzw/kxw -! -! Here Linsat == Fr_critical -! - Cx2sat = Linsat2*Cdf2 - if (etws >= cx2sat) then - Kds = kxw*Cx*rhp2/kzw3 - etws = cx2sat - taus = etws*kxw/kzw - Ind_out(i, ksrc) =-3 ! -3 - dignostic index for saturated waves - endif -! - betadis = cdf2/(Cx*Cx+cf2) - betaM = 1.0 /(1.0+betadis) - betaT = 1.0 - BetaM -! - Cxs = Cx - kzs = kzw -! keffs = (kvg(ksrc)+kds)*iPr_turb*.5*khp -! sp_kth(ksrc, i) = rhoi(ksrc)*keffs*(Tm(ksrc)+Tm(ksrc-1)) - rtaus(i) = taus*rhoi(ksrc) - sp_tau(ksrc, i) = rtaus(i) - sp_etot(ksrc, i) = etws - sp_mkz(ksrc, i) = kzw - sp_ek(ksrc, i) = etws*betam - sp_ep(ksrc, i) = etws*betaT ! can be transferred to (T'**2) T-rms - -! - ENDIF ! vertical propagation of i-mode to the next upper layer = (ksrc+1) -! -! Loop_Zint .................................. VERTICAL "INTERFACE" LOOP from ksrc => ktop_GW -! - Loop_Zi: do k=ksrc+1, levs -! - Cx = ch(i)-Um(k) ! Um(k) is defined at the interface pressure levels - Cdf2 = Cx*Cx -cf2 - if( Cx <= cd_ulim .or. Cdf2 <= 0.) then - Ind_out(i, k) =-1 ! 1 - diagnostic index for critical levels - ! print*,'crit level C-U ',int(Cx),int(sqrt(cf2)),' Um ',Um(k) - cycle Loop_GW - endif - - cdf1 =sqrt(Cdf2) - wdop2 = (kxw*Cx)* (kxw*Cx) - kzw2 = (Bn2(k)-wdop2)/Cdf2 - rhp4 - kx2_nh ! full lin DS-NIGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) - - if (kzw2 < 0.) then - Ind_out(i, k) =-2 ! 2 - diagnostic index for reflected waves - cycle Loop_GW - endif - kzw = sqrt(kzw2) - kzw3 =kzw2*kzw -! - keff_m = kvg(k)*kzw2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*kzw2 + krad(k) -! -! - betadis = cdf2 / (Cx*Cx+cf2) - betaM = 1.0 / (1.0+betadis) - betaT = 1.0 - BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*kzw2*F_kds + keff_m - wfiT = kds*iPr_ktgw*F_kds * kzw2 + keff_t -! - wfdM = wfiM/(kxw*Cdf1)*BetaM - wfdT = wfiT/(kxw*Cx)*BetaT -! exp-l: "kzi*dz" - kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) ! 2-factor energy-momentum (U')^2 -!------------------------------------------------------- -! dissipative factor: Fdis -! we can replace WKB-solver by Numerical integration of -! tau_gw == etot_gw/kzw*kxw -! d(rho*tau_gw) = -kdis*rho*tau_gw -! |tau_gw| <= |tau_gwsat| -! linear limit for single mode -! generalization for the "broad" spectra -! or treating single mode breaking -! over finite "vertical"-depth with "efficiency" -! Now: time-step + hor-l scale -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Fdis = exp(-kzi) -! -! -! dissipative "wave rms" by WKB -! - etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*kzw/kzs -! - Cx2sat = Linsat2*Cdf2 -! -! Linear saturation -! - if (etwk.ge.cx2sat) then - - Ind_out(i, k) =-3 ! 3 - dignostic index for saturated waves -! ! saturate energy and "trigger" keddy - etw_lin = etwk - etwk = cx2sat - Kds = kxw*Cdf1*rhp2/kzw3 - tauk = etwk*kxw/kzw - -!=================================================================================== -! WAM/case with high Kds tau_lin = (etw_lin-etwk)*kxw/kzw !tau_loss by sat theory -! Lzsat = 6,28/kzw Zsat1 = Zi(k)-.5*Lzsat -! Zsat2 = Zi(k)+.5*Lzsat -! in WAM triggering from "kds = 0 m2/s" => "200 m2/s" for Lzw ~ 10 km -! -! call sat_domain(zi, Zsat1, Zsat2, pver, ksat1, ksat2) -! -! to avoid it do the new diss-n factor with eddy "kds" added to the -! background keff_m and keff_t -! -! can be taken out for the strato-mesosphere in GFS -! wfiM = kds*kzw2 + keff_m -! wfiT = kds*iPr_ktgw * kzw2 +keff_t -! wfdM = wfiM/(kxw*Cdf1)*BetaM -! wfdT = wfiT/(kxw*Cx)*BetaT -! kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) -! Fdisat = exp(-kzi) -! etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*(kzw/Kzs) -! updated breaking in the Lzsat-domain: zsat1 < zi < zsat2 -! ================================================================================= - else - kds = 0.0 - tauk = etwk*kxw/kzw ! = Ekin*kx/kz - ENDIF -!-------------------------------------- -! -! Fill in spectral arrays(levs, nw) -! -!-------------------------------------- - sp_ked(k,i) = kds ! defined at interfaces - sp_tau(k, i) = tauk*rhoi(k) ! defined at interfaces - -! keff = (kds + kvg(k))*iPr_turb*0.5*KHP -! sp_kth(k, i) = rhoi(k)*keff*(Tm(k)+Tm(k-1)) ! defined at mid-layers - - sp_etot(k, i) = etwk ! defined at interfaces - sp_mkz(k, i) = kzw ! defined at interfaces - sp_ek(k, i) = etwk*betam ! defined at interfaces - sp_ep(k, i) = etwk*betaT ! can be transferred to (T'**2) -! -! - if (sp_tau(k,i) > sp_tau(k-1,i)) then - sp_tau(k,i) = sp_tau(k-1,i) ! prevent "possible" numerical "noise" - endif -! -! updates for "eps and keff" from -! - rab1 =.5*(cx+cxs)*dzirho(k) -! heating -! due to wave dissipation -! - sp_eps(k,i) = rab1*(sp_tau(k-1,i)- sp_tau(k,i)) ! defined at mid-layers -! -! cooling term due to eddy heat conduction =0 if Keff_cond =>0, -! usually updated by 1D-heat implict tridiagonal solver -! explicit local solver ---->sp_kth(k,i) = Kt*(dT/dz+ R/Cp*T/Hp~>g/cp) -! -! sp_eps(k,i)=sp_eps(k,i)+dzirho(k)*(sp_kth(k,i)- sp_kth(k-1,i)) -! - kzs = kzw - cxs = cX - taus = tauk - etws = etwk -! keffs = keff - - enddo Loop_Zi ! ++++++++++++++ vertical layer -! -! ................................! stop ' in solver single-mode' -! - enddo Loop_GW ! i-mode of GW-spectra -! - sum_rtaus =sum(rtaus) ! total momentum flux at k=ksrc - -! print *, sum_rtaus, ' tau-src ', nint(zi(ksrc)*1.e-3) -! print *, maxval(ch), minval(ch), ' Ch ', ngwv, ' N-modes ' -! -!============================================================================== -! Perform spectral integartion (sum) & apply "efficiency/inremittency" factors -! -! eff_factor: ~ 1./[number of modes in 1-direction of model columns] -! -!============================================================================== - do k=ksrc, levs - - ked(k) =0. - Eps(k) = 0. - Tau(k) = 0. - swg_et(k) =0. - swg_ep(k) =0. - swg_ek(k) =0. - - do i=1,nw - Ked(k) = Ked(k)+sp_ked(k,i) - Eps(k) = Eps(k)+sp_eps(k,i) - Tau(k) = Tau(k)+sp_tau(k,i) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! GW-energy + GW-en flux ~ Cgz*E, diagnostics-only -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - swg_et(k) = swg_et(k)+sp_etot(k,i) !*eff_fact - swg_ep(k) = swg_ep(k)+sp_ep(k,i) !*eff_fact - swg_ek(k) = swg_ek(k)+sp_ek(k,i) !*eff_fact - enddo - - enddo -! fill in below the "source" level ..... [1:ksrc-1] -! - do k=1, ksrc-1 -! no loss of the total momentum flux - ked(k) =0. - eps(k) = 0. - tau(k) = tau(ksrc) -! lin-theory diagnostics-only - swg_et(k) =swg_et(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ep(k) =swg_ep(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ek(k) =swg_ek(ksrc)*rhoi(ksrc)/rhoi(k) - enddo -! - RETURN -! -! diagnostics below -! -345 FORMAT(2x, F8.2, 4(2x, F10.3), 2x, F8.2) - if (dbg_print) then - print * - print *, ' Zkm EK m2/s2 Ked m2/s Eps m2/s3 tau-Mpa ' - do k=ksrc, levs -! Fd1 = maxval(Fdis_modes(1:nw,k)) -! Fd2 = minval(Fdis_modes(1:nw,k)) - write(6, 345) Zi(k)*1.e-3, sqrt(swg_ek(k)), Ked(k), Eps(k), Tau(k)*1.e3, Um(k) !, Fd1, Fd2 - enddo - print * - write(6,*) nw , ' nwaves-linsat ' - write(6,*) maxval(sp_ked), minval(sp_ked), 'ked ' - write(6,*) maxval(sp_tau), minval(sp_tau), 'sp_tau ' - !pause - endif - -! - end subroutine ugwp_lsatdis_az1 -! - subroutine ugwp_limit_1d(ax, ay,eps, ked, levs) - use cires_ugwp_module, only : max_kdis, max_eps, max_axyz - implicit none - integer :: levs - real, dimension(levs) :: ax, ay,eps - real, dimension(levs+1) :: ked - real, parameter :: xtiny = 1.e-30 - where (abs(ax) > max_axyz ) ax = ax/abs(ax+xtiny)*max_axyz - where (abs(ay) > max_axyz ) ay = ay/abs(ay+xtiny)*max_axyz - where (abs(eps) > max_eps ) eps = eps/abs(eps+xtiny)*max_eps - where (ked > max_kdis ) ked = max_kdis - end subroutine ugwp_limit_1d diff --git a/physics/cires_vert_orodis.F90 b/physics/cires_vert_orodis.F90 deleted file mode 100644 index 0d3cce194..000000000 --- a/physics/cires_vert_orodis.F90 +++ /dev/null @@ -1,1018 +0,0 @@ -! subroutine ugwp_drag_mtb -! subroutine ugwp_taub_oro -! subroutine ugwp_oro_lsatdis -! - subroutine ugwp_drag_mtb( iemax, nz, & - elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) - - use ugwp_common, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init,only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver - - implicit none -!======================== -! several versions for drmtb => high froude mountain blocking -! version 1 => vay_2018 ; -! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 -! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 -!======================== - -! character(len=8) :: strver = 'vay_2018' -! real, parameter :: Fcrit_mtb = 0.7 - - integer, intent(in) :: nz - integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime - real , intent(out) :: taumtb - - integer , intent(out) :: idxzb - real, dimension(nz), intent(out) :: drmtb - - real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) - real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam - real, intent(in) :: zpbl - - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: zpi, pint -! - real, dimension(nz+1) :: zpi_zero - real, dimension(nz) :: zpm_zero - real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp - - real, dimension(nz) :: bn2, uds, umf, cosang, sinang - - integer :: k, klow, ktop, kpbl - real :: uhm, vhm, bn2hm, rhohm, & - mtb_fix, umag, bnmag, frd_src, & - zblk, who_iz_normal, rlm97, & - phiang, ang, pe, ek, & - cang, sang, ss2, cs2, zlen, dbtmp, & - hamp, bgamm, cgamm - -!================================================== -! -! elvp + hprime <=>elvp + nridge*hprime, ns =2 -! ns = sigfac -! tau_parel & tau_normal along major "axes" -! -! options to block the "flow", choices for [klow, ktop] -! -! 1-directional (normal) & 2-directional "blocking" -! -!================================================== -! no - blocking: drmtb(1:nz) = 0.0 -!================= - idxzb = -1 - drmtb(1:nz) = 0.0 - taumtb = 0.0 - klow = 2 - - ktop = iemax - hamp = nridge*hprime - -! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime - - mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - - if (mtb_fix == 0.) then - print *, cdmb, sigma, hamp - print *, ' MTB == 0' - stop - endif - - if (strver == 'vay_2018') then - - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - - do k=1, nz-1 - if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then - ktop = k+1 !......simply k+1 next interface level - exit - endif - enddo -! print *, klow, ktop, ' klow-ktop ' - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - if (bn2hm .le. 0.0) then - print *, ' unstable MF for MTB -RETURN ' - RETURN ! unstable PBL - endif - bnmag =sqrt(bn2hm) - - frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. - -! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' -! - if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking -! -! zblk > 0 -! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk -! - zblk = hamp*(1. - Fcrit_mtb/frd_src) - idxzb =1 - do k = 2, ktop - - if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then - idxzb = k - exit - endif - enddo -! - if (idxzb == 1) RETURN ! first surface level block is not "important" - - if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 -! -! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 -! - bgamm = 1.0 - 0.18*gam -0.04*gam*gam - cgamm = 0.48*gam +0.3*gam*gam - - do k = 1, idxzb-1 - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - - umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - - phiang = atan(vp(k)/umag) -! theta -90/90 - ang = theta - phiang - cang = cos(ang) ; sang = sin(ang) - - who_iz_normal = max(cang, gam*sang ) !gfs-2018 - - cs2 = cang* cang ; ss2 = 1.-cs2 - - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it -! - if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level -! - - who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS - - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - if (dbtmp < 0) dbtmp = 0.0 -! -! several approximation can be made to implement MTB-drag -! as a "nonlinear level dependent"-drag or "constant"-drag -! uds(k) == umag = const between the 1-layer and idxzb -! - - drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u - taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! -! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used -! with Umag-projections on A & B ellipse axes -! mtb_fix =0.25*cdmb*sigma/hprime, -! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. -! -!333 format(i4, 7(2x, F10.3)) -! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 - enddo -! - endif - endif ! strver=='vay_2018' -! -! -! - if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then - - print *, ' kdn_2005 with # of hills ' -! -! compute flow-blocking stress based on WRF 'gwdo2d' -! - endif -! -! - if (strver == 'gfs_2018') then - - ktop = iemax; klow = 2 - - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - if (bn2hm <= 0.0) RETURN ! unstable PBL -!--------------------------------------------- -! -!'gfs_2018' .... does not rely on Fr_crit -! and Fr-regimes -!----gfs17 for mtn ignores "averaging of the flow" -! for MTB-part it is only works with "angles" -! no projections on [uhm, vhm] -direction -! kpbl can be used for getting high values of iemax-hill -!----------------------------------------------------------- - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - do k=1, nz-1 - if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then - kpbl = k+1 - exit - endif - enddo - - do k = iemax, 1, -1 - - uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - phiang = atan(vp(k)/uds(k)) - ang = theta - phiang - cosang(k) = cos(ang) - sinang(k) = sin(ang) - - if (idxzb == 0) then - pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) - umf(k) = uds(k) * cosang(k) ! normal to main axis - ek = 0.5 * umf(k) * umf(k) -! -! --- dividing stream lime is found when pe =>exceeds ek first from the "top" -! - if (pe >= ek) idxzb = k - exit - endif - enddo - -! idxzb = min(kpbl, idxzb) -! -! -! -! last: mtb-drag -! - if (idxzb > 1) then - zblk = zpm(idxzb) - print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) - do k = idxzb-1, 1, -1 -! - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - cs2 = cosang(k)* cosang(k) - ss2 = 1.-cs2 - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it - - who_iz_normal = max(cosang(k), gam*sinang(k)) -! -! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) -! - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - - drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u -! - taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! - enddo - endif - endif ! strver=='gfs17' -! -! - end subroutine ugwp_drag_mtb -! -! -! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] -! -! - subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & - hprime , sigma, theta, oc, oa4, clx4, gamm, & - elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & - tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) -! - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin - use cires_ugwp_module, only : frcrit, ricrit, linsat - use ugwp_oro_init, only : hpmax, cleff, frmax - use ugwp_oro_init, only : nwdir, mdir, fdir - use ugwp_oro_init, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init, only : coro, nridge, odmin, odmax - use ugwp_oro_init, only : strver -! - use ugwp_oro_init, only : mkz2min, lzmax, zbr_pi -! --- -! -! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) -! approximate for drlee-momentum tendency -! --- - implicit none -! - integer, intent(in) :: levs, izb - real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero - integer, intent(out) :: kdswj, krefj, kotr - integer :: klwb - real, intent(in) :: kxw, fcor - real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp - -! - real, intent(in) :: oa4(4), clx4(4) - - real, dimension(levs), intent(in) :: up, vp, tp, qp, dp - real, dimension(levs+1), intent(in) :: zpi, pint - real, dimension(levs ), intent(in) :: zpm, pmid -! - real,dimension(levs), intent(out) :: drlee - real,dimension(levs+1), intent(out) :: tau_src -! - real, intent(out) :: tauogw, tautot, taulee - real :: taulin, tauhcr, taumtb - real, intent(out) :: xn, yn, umag, kxridge -! -! -! locals -! four possible versions to compute "taubase as a function of Fr-number" -! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' -! - real, dimension(levs+1) :: zpi_zero - - real :: oa, clx, odir, cl4p(4), clxp - - real :: uhm, vhm, bn2hm, rhohm, bnv - - real :: elvpMTB, wdir - real :: tem, efact, coefm, kxlinv, gfobnv - - real :: fr, frlin, frlin2, frlin3, frlocal, dfr - real :: betamax, betaf, frlwb, frmtb - integer :: klow, ktop, kph - - integer :: i, j, k, nwd, ind4, idir - - real :: sg_ridge, kx2, umd2 - real :: mkz, mkz2, zbr_mkz, mkzi - - real :: hamp ! clipped hprime*elvmax/elv_clip > hprime - real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) - real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves - real :: hcrit - real :: hblk ! blocking div-stream height - - real :: coef_h2, frnorm - - - real, dimension(levs) :: bn2 - real :: rho(levs) - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - real, dimension(levs+1) :: umd, phmkz - real :: c2f2, umag2, dzwidth, udir - real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp - real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms - real, dimension(levs+1) :: dtrans, deff - real :: pdtrans - logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 - logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum - ! between ZMTB => ZHILL -!----------------------------------------------------------------------------- -! -! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) -! ZMTB < ZOGW = ns*HPRIME < ELVP -! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB -! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new -! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW -! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB -! -!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] -! can be based on numerical runs like WRF-model -! for Frc < Fr< [Frc : 2.5-3 Frc] -! see suggestions proposed in SM-2000 and Eckermann et al. (2010) -!----------------------------------------------------------------------------- - tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 - krefj = 1 ; kotr = levs+1; kdswj = 1 - xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw - - dtrans = 0. ; deff =0. - klow = 2 - elvpMTB = elvp -! -! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB -! - if (izb > 0 ) then - klow = izb - elvpMTB = max(elvp - zpi(izb), 0.0) - endif - if (elvpMTB <=0 ) print *, ' blocked flow ' - if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX - - zpi_zero(:) = zpi(:) - zpi(1) - hblk = zpi_zero(klow) - - sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) - -! -! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp -! - sg_ridge = min(sg_ridge, hpmax) - -! print *, 'sg_ridge ', sg_ridge - - do k=1, levs - if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then - ktop = k+1 - exit - endif - enddo - - krefj = ktop ! the mountain top index for sg_ridge = ns*hprime - -! if ( izb > 0 .and. krefj .le. izb) then -! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' -! endif - -! -! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L -! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution -! - call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - call get_unit_vector(uhm, vhm, xn, yn, umag) - - if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment - bnv = sqrt(bn2hm) - hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer - hogw = hamp - hdsw = hamp - - - fr = bnv * hamp /umag - fr = min(fr, frmax) - kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx - kx2 = kxridge*kxridge - umag = max( umag, velmin) - c2f2 = fcor*fcor/kx2 - umag2 = umag*umag - c2f2 - - if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx - - mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" - ! and non-stationary waves coro, fcor for small umag - ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg - IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN -! -! case then no effects of wave-orography -! - krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 - tautot = 0. - tauogw = 0. - taulee = 0. - drlee = 0. ; tau_src(1:levs+1) = 0. - return - ENDIF -!========================================================================= -! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! make sure that SM_00 and KD_05 oro-characteristics can match each other -! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime -! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] -! alph-SM00 fraction of h2d contributed to hprime [0:1] -! -! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] -! delt-SM00 dw/up asymmetry -1 < delta < 1 -! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 -!.. -!A parametrization of low-level wave breaking which includes a dependence on -!the degree of 2-dimensionality of SG; it is active over a finite range of Fr -!========================================================================= - wdir = atan2(uhm,vhm) + pi - idir = mod( int(fdir*wdir),mdir) + 1 - - nwd = nwdir(idir) - ind4 = mod(nwd-1,4) + 1 - if (ind4 < 1 ) ind4 = 1 - if (ind4 > 4 ) ind4 = 4 - - oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) - clx = clx4(ind4) - cl4p(1) = clx4(2) - cl4p(2) = clx4(1) - cl4p(3) = clx4(4) - cl4p(4) = clx4(3) - clxp = cl4p(ind4) - - odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" - - odir = min(odmax, odir) - odir = max(odmin, odir) - - - if (strver == 'smc_2000' .or. strver == 'vay_2018') then -!========================================================================= -! -! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb -! taulin/tauogw taulee taumtb -! here tau_src(levs+1): approximate wave flux from surface to LLWB -! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) -!========================================================================= -! -! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 -! wave flux ~ rho_src*kx_src/mkz_src*wind_rms -! bn2, uhm, vhm, bn2hm, rhohm -! -! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN -! -! wave regimes -! - mkz = sqrt(mkz2) - frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb - frlin = fcrit_sm - frlin2 = 1.5*fcrit_sm - frlin3 = 3.0*fcrit_sm - - hcrit = fcrit_sm*umag/bnv - hogw = min(hamp, hcrit) - hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution - - coef_h2 = kxridge * rhohm * bnv * umag - - taulin = coef_h2 * hamp*hamp - tauhcr = coef_h2 * hcrit*hcrit - - IF (fr < frlin ) then - tauogw = taulin - taulee = 0.0 - taumtb = 0.0 - else if (fr .ge. frlin ) then - tauogw = tauhcr - taulin = coef_h2 * hamp*hamp - taumtb = tau_izb ! integrated form MTB -! -! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? -! - frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] - BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] - - if ( fr <= frlin2 ) then - Betaf= 2.*BetaMax*(frNorm-1.0) - taulee = (1. + Betaf )*taulin - tauhcr - else if ( (fr > frlin2).and.(fr <= frlin3))then - Betaf=-1.+ 1./frnorm/frnorm + & - (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) - taulee = (1. + Betaf )*taulin - tauhcr -!============== -! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) -! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) -! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) -! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) -! -!============== - else - taulee = 0.0 - hdsw = 0.0 - endif - ENDIF - - tautot = tauogw + taulee + taumtb*0. - - IF (taulee > 0.0 ) THEN - - hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge -! -! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves -! make "empirical" height above elvp that may represent DSW-wave breaking & trapping -! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge -! - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) ! kph marks the low-level of wave solutions - klwb = kph ! klwb above blocking marks wave-breaking - kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level - - if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) - - udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) - hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) - umd(krefj) = udir - - udir = max(ui(kph)*xn +vi(kph)*yn, velmin) - hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) - umd(kph) = udir - ! what we can put between k =[kph:krefj] - phmkz(:) = 0.0 ! - phmkz(kph-1) = fr ! initial Phase of the low-level wave -! -! now transfer tau_layer => tau_level assuming tau_layer = tau_level -! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT -! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 -! - loop_lwb_otr: do k=kph+1, krefj ! levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, dw2min) -c2f2 - - - if (umd2 <= 0.0) then -! -! critical layer -! - klwb = k - kotr = k - exit loop_lwb_otr - endif - - mkz2 = bn2i(k)/umd2 - kx2 - - if ( mkz2 >= mkz2min ) then -! -! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 -! at finest vertical resolution we can meet "abrupt" mkz -! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km -! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) -! - mkz = sqrt(mkz2) - hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) - udswz = hdswz *bn2i(k) -!=========================================================================================== -!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 -! -! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz -! by k = krefj tautot = tauogw(krefj) -!=========================================================================================== - if (do_klwb_phase) then - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then - klwb = min(k, krefj) - exit loop_lwb_otr - endif - endif - else ! mkz2 < mkz2min - kotr = k ! trapped/reflected waves / - exit loop_lwb_otr - endif - enddo loop_lwb_otr -! -! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee -! tau_trapped ??? -! - if (do_klwb_phase) then - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif -! -! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) -! more complicated is dissipative saturation pdtrans =/= constant -! - if (do_dtrans) then - do k=kph, krefj - tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) - drlee(k) = -tau_src(k)/rho(k) * pdtrans - enddo - endif - - - ENDIF !taulee > 0.0 - - - endif !strver -! - -!========================================================================= - if (strver == 'gfs_2018' .or. strver == 'kd_2005') then -!========================================================================= -! -! orowaves: OGW+DSW/Lee -! - efact = (oa + 2.0) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + clx) ** (oa+1.) - - kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx - kxlinv = coefm * cleff - tem = fr * fr * oc - gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 -!========================================================================= -! source fluxes: taulin, taufrb -!========================================================================= - tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact - - coef_h2 = kxlinv *rhohm * bnv*umag - taulin = coef_h2 *hamp*hamp - hcrit = fcrit_gfs*umag/bnv - tauhcr = coef_h2 *hcrit*hcrit - - IF (fr <= fcrit_gfs) then - tauogw = taulin - tautot = taulin - taulee = 0. - drlee(:) = 0. - ELSE !fr > fcrit_gfs - tauogw = tauhcr - taulee = max(tautot - tauogw, 0.0) - if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) -! approximate drlee(k) between [izb, klwb] -! find klwb and decrease taulee(izb) => taulee(klwb) = 0. -! above izb tau - if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then - - mkz = sqrt(mkz2) - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) - phmkz(:) = 0.0 - klwb = max(izb, 1) - kotr = levs+1 - phmkz(kph-1) = fr ! initial Phase of the Lee-OGW - - loop_lwb_gfs18: do k=kph, levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, velmin*velmin) - mkz2 = bn2i(k)/umd2 - kx2 - if ( mkz2 > mkz2min ) then - mkz = sqrt(mkz2) - frlocal = max(hdsw*bvi(k)/umd(k), frlwb) - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k - else - kotr = k - exit loop_lwb_gfs18 - endif - enddo loop_lwb_gfs18 -! -! - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 - ENDIF !fr > fcrit_gfs - - - ENDIF !strbase='gfs2017' .or. strbase='kd_2005' - - -! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge -! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' -! - end subroutine ugwp_taub_oro -! -!-------------------------------------- -! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & -! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & -! xn, yn, umag, drtau, kdis_oro) - - subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - xn, yn, umag, drtau, kdis) - - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav - use cires_ugwp_module, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module, only : kvg, ktg, krad, kion - use ugwp_oro_init, only : coro , fcrit_sm , fcrit_sm2 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - real , dimension(levs+1) :: tau_src - - real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm - real, dimension(levs+1), intent(in) :: zpi, pmid, pint - real , intent(in) :: xn, yn, umag - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: uref, udir, uf2, ufd, uf2p - real, dimension(levs+1) :: tauz - real, dimension(levs) :: rho - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, kcrit, kref - real :: kx2, kx2w, kxs - real :: mkzm, mkz, dkz, mkz2, ch, kzw3 - real :: wfdM, wfdT, wfiM, wfiT - real :: fdis, mkzi, keff_m, keff_t - real :: betadis, betam, betat, cdfm, cdft - real :: fsat, hsat, hsat2, kds , c2f2 - - drtau(1:levs) = 0.0 - kdis (1:levs) = 0.0 - - ch = coro - - kx2w = kxw*kxw - kx2 = kxridge*kxridge - if( kx2 < kx2w ) kx2 = kx2w - kxs = sqrt(kx2) - c2f2 = fcor*fcor/kx2 -! -! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) -! -! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -!=============================================================================== -! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 -! rotational/non-hyrostatic effects are important only for high-res runs -! Udir = 0, Udir < 0 are not -! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz -! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) -! stochastic "tauogw'-setup+ sigma_tau ; -! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves -! target is to get "multiple"-saturation levels for OGWs -!=============================================================================== - tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode - ! sign of tauz > 0...and its attenuate with Z - k = krefj - uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves - uf2 = uref*uref - c2f2 - if (uf2 > 0) then - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2.gt.0) then - mkzm = sqrt(mkz2) - else - return ! wave reflection mkz2 <=0. - endif - else - return ! wave absorption uf2 <= 0. - endif -! -! upward solver for single "mode" with tauz(levs+1) =0. at the top -! - kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer - kcrit = levs - do k= krefj+1, levs -! -! 2D-wave propagation along reference-wind direction -! udir = 0 critical wind for coro =0 -! cdop = -uref .... upwind waves travel against MF -! - udir = ui(k)*xn +vi(k)*yn - uf2 = udir*udir - c2f2 - - - if (uf2 < dw2min .or. udir <= 0.0) then - kcrit =K - tauz(kcrit:levs) = 0. - exit ! vert-level loop - endif -! -! wave-based solution -! - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2 > 0) then - mkzm = sqrt(mkz2) -! -! do dissipative flux vs saturation: kvg, ktg, krad, kion -! - kzw3 = mkzm*mkz2 -! - keff_m = kvg(k)*mkz2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*mkz2 + krad(k) -! -! - uf2p = uf2 + 2.0*c2f2 - betadis = uf2/uf2p - betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw - betaT = 1.0- BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*mkz2 + keff_m - wfiT = kds*mkz2 + keff_t -! - cdfm = sqrt(uf2)*kxs - cdft = abs(udir)*kxs - wfdM = wfiM/cdfm *BetaM - wfdT = wfiT/Cdft *BetaT - mkzi = 2.0*mkzm*(wfdM+wfdT) - - fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) - tauz(k) = fdis - hsat2 = fcrit_sm2 * uf2 *bn2i(k) - fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) - if (fdis > fsat) then - tauz(k) = min(fsat, tauz(k-1)) -!================================================================= -! two definitions for eddy mixing of MF: -! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 -! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 -!================================================================= - kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) - kdis(k) = kds - endif - else - tauz(k:levs) = 0. ! wave is reflected above - kds = 0. - endif - enddo - - do k=krefj+1, kcrit - drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) - enddo -! -! - end subroutine ugwp_oro_lsatdis -! -! - subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none -! - integer :: im, levs - real(kind_phys), dimension(im, levs) :: u, v, zmid - real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl - real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sgh = 30. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - - do i=1, im - - zdec = max(n_tofd*sigflt(i), zpbl(i)) - zdec = min(ze_tofd, zdec) - rzdec = 1.0/zdec - sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) - - do k=1, levs - zmet = zmid(i,k) - if (zmet > ztop_tofd) cycle - ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) - umag = sqrt(ekin) - zarg = zmet*rzdec - zexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp - utofd(i,k) = -krf*u(i,k) - vtofd(i,k) = -krf*v(i,k) - epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re - krf_tofd(i,k) = krf - enddo - enddo -! - end subroutine ugwp_tofd -! -! - subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none - integer :: levs - real(kind_phys), dimension(levs) :: u, v, zmid - real(kind_phys) :: sigflt, elvmax, zpbl, zsurf - real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sghmax = 5. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl - zdec = min(ze_tofd, zdec) ! cannot exceed 18 km - rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - - do k=1, levs - zmet = zmid(k)-zsurf - if (zmet > ztop_tofd) cycle - ekin = u(k)*u(k) + v(k)*v(k) - umag = sqrt(ekin) - zarg = zmet*rzdec - ztexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp - - utofd(k) = -krf*u(k) - vtofd(k) = -krf*v(k) - epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re; epstofd(k) can be skipped - krf_tofd(k) = krf - enddo -! - end subroutine ugwp_tofd1d diff --git a/physics/cires_vert_orodis_v1.F90 b/physics/cires_vert_orodis_v1.F90 deleted file mode 100644 index 852c114b0..000000000 --- a/physics/cires_vert_orodis_v1.F90 +++ /dev/null @@ -1,1047 +0,0 @@ -module cires_vert_orodis_v1 - - -contains - - -! subroutine ugwp_drag_mtb -! subroutine ugwp_taub_oro -! subroutine ugwp_oro_lsatdis -! - subroutine ugwp_drag_mtb( iemax, nz, & - elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) - - use ugwp_common_v1, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init_v1, only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver - - implicit none -!======================== -! several versions for drmtb => high froude mountain blocking -! version 1 => vay_2018 ; -! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 -! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 -!======================== -! real, parameter :: Fcrit_mtb = 0.7 - - integer, intent(in) :: nz - integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime - real , intent(out) :: taumtb - - integer , intent(out) :: idxzb - real, dimension(nz), intent(out) :: drmtb - - real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) - real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam - real, intent(in) :: zpbl - - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: zpi, pint - - ! character(len=*), intent(out) :: errmsg - ! integer, intent(out) :: errflg -! - real, dimension(nz+1) :: zpi_zero - real, dimension(nz) :: zpm_zero - real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp - - real, dimension(nz) :: bn2, uds, umf, cosang, sinang - - integer :: k, klow, ktop, kpbl - real :: uhm, vhm, bn2hm, rhohm, & - mtb_fix, umag, bnmag, frd_src, & - zblk, who_iz_normal, rlm97, & - phiang, ang, pe, ek, & - cang, sang, ss2, cs2, zlen, dbtmp, & - hamp, bgamm, cgamm - - - ! Initialize CCPP error handling variables - ! errmsg = '' - ! errflg = 0 - -!================================================== -! -! elvp + hprime <=>elvp + nridge*hprime, ns =2 -! ns = sigfac -! tau_parel & tau_normal along major "axes" -! -! options to block the "flow", choices for [klow, ktop] -! -! 1-directional (normal) & 2-directional "blocking" -! -!================================================== -! no - blocking: drmtb(1:nz) = 0.0 -!================= - idxzb = -1 - drmtb(1:nz) = 0.0 - taumtb = 0.0 - klow = 2 - - ktop = iemax - hamp = nridge*hprime - -! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime - - mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - - ! if (mtb_fix == 0.) then - ! write(errmsg,'(*(a))') cdmb, sigma, hamp, ' MTB == 0' - ! errflg = 1 - ! return - ! endif - - if (strver == 'vay_2018') then - - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - - do k=1, nz-1 - if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then - ktop = k+1 !......simply k+1 next interface level - exit - endif - enddo -! print *, klow, ktop, ' klow-ktop ' - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - ! if (bn2hm .le. 0.0) then - ! write(errmsg,'(*(a))') 'unstable MF for MTB - RETURN ' - ! errflg = 1 - ! return ! unstable PBL - ! end if - - bnmag =sqrt(bn2hm) - - frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. - -! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' -! - if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking -! -! zblk > 0 -! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk -! - zblk = hamp*(1. - Fcrit_mtb/frd_src) - idxzb =1 - do k = 2, ktop - - if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then - idxzb = k - exit - endif - enddo -! - if (idxzb == 1) RETURN ! first surface level block is not "important" - - if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 -! -! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 -! - bgamm = 1.0 - 0.18*gam -0.04*gam*gam - cgamm = 0.48*gam +0.3*gam*gam - - do k = 1, idxzb-1 - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - - umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - - phiang = atan(vp(k)/umag) -! theta -90/90 - ang = theta - phiang - cang = cos(ang) ; sang = sin(ang) - - who_iz_normal = max(cang, gam*sang ) !gfs-2018 - - cs2 = cang* cang ; ss2 = 1.-cs2 - - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it -! - if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level -! - - who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS - - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - if (dbtmp < 0) dbtmp = 0.0 -! -! several approximation can be made to implement MTB-drag -! as a "nonlinear level dependent"-drag or "constant"-drag -! uds(k) == umag = const between the 1-layer and idxzb -! - - drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u - taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! -! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used -! with Umag-projections on A & B ellipse axes -! mtb_fix =0.25*cdmb*sigma/hprime, -! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. -! -!333 format(i4, 7(2x, F10.3)) -! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 - enddo -! - endif - endif ! strver=='vay_2018' -! -! -! - if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then - - print *, ' kdn_2005 with # of hills ' -! -! compute flow-blocking stress based on WRF 'gwdo2d' -! - endif -! -! - if (strver == 'gfs_2018') then - - ktop = iemax; klow = 2 - - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - if (bn2hm <= 0.0) RETURN ! unstable PBL -!--------------------------------------------- -! -!'gfs_2018' .... does not rely on Fr_crit -! and Fr-regimes -!----gfs17 for mtn ignores "averaging of the flow" -! for MTB-part it is only works with "angles" -! no projections on [uhm, vhm] -direction -! kpbl can be used for getting high values of iemax-hill -!----------------------------------------------------------- - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - do k=1, nz-1 - if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then - kpbl = k+1 - exit - endif - enddo - - do k = iemax, 1, -1 - - uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - phiang = atan(vp(k)/uds(k)) - ang = theta - phiang - cosang(k) = cos(ang) - sinang(k) = sin(ang) - - if (idxzb == 0) then - pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) - umf(k) = uds(k) * cosang(k) ! normal to main axis - ek = 0.5 * umf(k) * umf(k) -! -! --- dividing stream lime is found when pe =>exceeds ek first from the "top" -! - if (pe >= ek) idxzb = k - exit - endif - enddo - -! idxzb = min(kpbl, idxzb) -! -! -! -! last: mtb-drag -! - if (idxzb > 1) then - zblk = zpm(idxzb) - print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) - do k = idxzb-1, 1, -1 -! - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - cs2 = cosang(k)* cosang(k) - ss2 = 1.-cs2 - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it - - who_iz_normal = max(cosang(k), gam*sinang(k)) -! -! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) -! - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - - drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u -! - taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! - enddo - endif - endif ! strver=='gfs17' -! -! - end subroutine ugwp_drag_mtb -! -! -! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] -! -! - subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & - hprime , sigma, theta, oc, oa4, clx4, gamm, & - elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & - tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) -! - use ugwp_common_v1, only : bnv2min, grav, pi, pi2, dw2min, velmin - use ugwp_common_v1, only : mkz2min, mkzmin - use cires_ugwp_module_v1, only : frcrit, ricrit, linsat - use ugwp_oro_init_v1, only : hpmax, cleff, frmax - use ugwp_oro_init_v1, only : nwdir, mdir, fdir - use ugwp_oro_init_v1, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init_v1, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init_v1, only : coro, nridge, odmin, odmax - use ugwp_oro_init_v1, only : strver -! - use ugwp_oro_init_v1, only : zbr_pi -! --- -! -! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) -! approximate for drlee-momentum tendency -! --- - implicit none -! - integer, intent(in) :: levs, izb - real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero - integer, intent(out) :: kdswj, krefj, kotr - integer :: klwb - real, intent(in) :: kxw, fcor - real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp - -! - real, intent(in) :: oa4(4), clx4(4) - - real, dimension(levs), intent(in) :: up, vp, tp, qp, dp - real, dimension(levs+1), intent(in) :: zpi, pint - real, dimension(levs ), intent(in) :: zpm, pmid -! - real,dimension(levs), intent(out) :: drlee - real,dimension(levs+1), intent(out) :: tau_src -! - real, intent(out) :: tauogw, tautot, taulee - real :: taulin, tauhcr, taumtb - real, intent(out) :: xn, yn, umag, kxridge -! -! -! locals -! four possible versions to compute "taubase as a function of Fr-number" -! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' -! - real, dimension(levs+1) :: zpi_zero - - real :: oa, clx, odir, cl4p(4), clxp - - real :: uhm, vhm, bn2hm, rhohm, bnv - - real :: elvpMTB, wdir - real :: tem, efact, coefm, kxlinv, gfobnv - - real :: fr, frlin, frlin2, frlin3, frlocal, dfr - real :: betamax, betaf, frlwb, frmtb - integer :: klow, ktop, kph - - integer :: i, j, k, nwd, ind4, idir - - real :: sg_ridge, kx2, umd2 - real :: mkz, mkz2, zbr_mkz, mkzi - - real :: hamp ! clipped hprime*elvmax/elv_clip > hprime - real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) - real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves - real :: hcrit - real :: hblk ! blocking div-stream height - - real :: coef_h2, frnorm - - - real, dimension(levs) :: bn2 - real :: rho(levs) - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - real, dimension(levs+1) :: umd, phmkz - real :: c2f2, umag2, dzwidth, udir - real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp - real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms - real, dimension(levs+1) :: dtrans, deff - real :: pdtrans - logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 - logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum - ! between ZMTB => ZHILL -!----------------------------------------------------------------------------- -! -! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) -! ZMTB < ZOGW = ns*HPRIME < ELVP -! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB -! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new -! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW -! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB -! -!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] -! can be based on numerical runs like WRF-model -! for Frc < Fr< [Frc : 2.5-3 Frc] -! see suggestions proposed in SM-2000 and Eckermann et al. (2010) -!----------------------------------------------------------------------------- - tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 - krefj = 1 ; kotr = levs+1; kdswj = 1 - xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw - - dtrans = 0. ; deff =0. - klow = 2 - elvpMTB = elvp -! -! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB -! - if (izb > 0 ) then - klow = izb - elvpMTB = max(elvp - zpi(izb), 0.0) - endif - if (elvpMTB <=0 ) print *, ' blocked flow ' - if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX - - zpi_zero(:) = zpi(:) - zpi(1) - hblk = zpi_zero(klow) - - sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) - -! -! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp -! - sg_ridge = min(sg_ridge, hpmax) - -! print *, 'sg_ridge ', sg_ridge - - do k=1, levs - if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then - ktop = k+1 - exit - endif - enddo - - krefj = ktop ! the mountain top index for sg_ridge = ns*hprime - -! if ( izb > 0 .and. krefj .le. izb) then -! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' -! endif - -! -! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L -! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution -! - call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - call get_unit_vector(uhm, vhm, xn, yn, umag) - - if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment - bnv = sqrt(bn2hm) - hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer - hogw = hamp - hdsw = hamp - - - fr = bnv * hamp /umag - fr = min(fr, frmax) - kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx - kx2 = kxridge*kxridge - umag = max( umag, velmin) - c2f2 = fcor*fcor/kx2 - umag2 = umag*umag - c2f2 - - if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx - - mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" - ! and non-stationary waves coro, fcor for small umag - ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg - IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN -! -! case then no effects of wave-orography -! - krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 - tautot = 0. - tauogw = 0. - taulee = 0. - drlee = 0. ; tau_src(1:levs+1) = 0. - return - ENDIF -!========================================================================= -! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! make sure that SM_00 and KD_05 oro-characteristics can match each other -! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime -! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] -! alph-SM00 fraction of h2d contributed to hprime [0:1] -! -! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] -! delt-SM00 dw/up asymmetry -1 < delta < 1 -! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 -!.. -!A parametrization of low-level wave breaking which includes a dependence on -!the degree of 2-dimensionality of SG; it is active over a finite range of Fr -!========================================================================= - wdir = atan2(uhm,vhm) + pi - idir = mod( int(fdir*wdir),mdir) + 1 - - nwd = nwdir(idir) - ind4 = mod(nwd-1,4) + 1 - if (ind4 < 1 ) ind4 = 1 - if (ind4 > 4 ) ind4 = 4 - - oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) - clx = clx4(ind4) - cl4p(1) = clx4(2) - cl4p(2) = clx4(1) - cl4p(3) = clx4(4) - cl4p(4) = clx4(3) - clxp = cl4p(ind4) - - odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" - - odir = min(odmax, odir) - odir = max(odmin, odir) - - - if (strver == 'smc_2000' .or. strver == 'vay_2018') then -!========================================================================= -! -! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb -! taulin/tauogw taulee taumtb -! here tau_src(levs+1): approximate wave flux from surface to LLWB -! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) -!========================================================================= -! -! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 -! wave flux ~ rho_src*kx_src/mkz_src*wind_rms -! bn2, uhm, vhm, bn2hm, rhohm -! -! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN -! -! wave regimes -! - mkz = sqrt(mkz2) - frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb - frlin = fcrit_sm - frlin2 = 1.5*fcrit_sm - frlin3 = 3.0*fcrit_sm - - hcrit = fcrit_sm*umag/bnv - hogw = min(hamp, hcrit) - hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution - - coef_h2 = kxridge * rhohm * bnv * umag - - taulin = coef_h2 * hamp*hamp - tauhcr = coef_h2 * hcrit*hcrit - - IF (fr < frlin ) then - tauogw = taulin - taulee = 0.0 - taumtb = 0.0 - else if (fr .ge. frlin ) then - tauogw = tauhcr - taulin = coef_h2 * hamp*hamp - taumtb = tau_izb ! integrated form MTB -! -! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? -! - frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] - BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] - - if ( fr <= frlin2 ) then - Betaf= 2.*BetaMax*(frNorm-1.0) - taulee = (1. + Betaf )*taulin - tauhcr - else if ( (fr > frlin2).and.(fr <= frlin3))then - Betaf=-1.+ 1./frnorm/frnorm + & - (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) - taulee = (1. + Betaf )*taulin - tauhcr -!============== -! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) -! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) -! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) -! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) -! -!============== - else - taulee = 0.0 - hdsw = 0.0 - endif - ENDIF - - tautot = tauogw + taulee + taumtb*0. - - IF (taulee > 0.0 ) THEN - - hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge -! -! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves -! make "empirical" height above elvp that may represent DSW-wave breaking & trapping -! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge -! - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) ! kph marks the low-level of wave solutions - klwb = kph ! klwb above blocking marks wave-breaking - kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level - - if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) - - udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) - hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) - umd(krefj) = udir - - udir = max(ui(kph)*xn +vi(kph)*yn, velmin) - hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) - umd(kph) = udir - ! what we can put between k =[kph:krefj] - phmkz(:) = 0.0 ! - phmkz(kph-1) = fr ! initial Phase of the low-level wave -! -! now transfer tau_layer => tau_level assuming tau_layer = tau_level -! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT -! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 -! - loop_lwb_otr: do k=kph+1, krefj ! levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, dw2min) -c2f2 - - - if (umd2 <= 0.0) then -! -! critical layer -! - klwb = k - kotr = k - exit loop_lwb_otr - endif - - mkz2 = bn2i(k)/umd2 - kx2 - - if ( mkz2 >= mkz2min ) then -! -! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 -! at finest vertical resolution we can meet "abrupt" mkz -! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km -! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) -! - mkz = sqrt(mkz2) - hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) - udswz = hdswz *bn2i(k) -!=========================================================================================== -!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 -! -! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz -! by k = krefj tautot = tauogw(krefj) -!=========================================================================================== - if (do_klwb_phase) then - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then - klwb = min(k, krefj) - exit loop_lwb_otr - endif - endif - else ! mkz2 < mkz2min - kotr = k ! trapped/reflected waves / - exit loop_lwb_otr - endif - enddo loop_lwb_otr -! -! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee -! tau_trapped ??? -! - if (do_klwb_phase) then - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif -! -! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) -! more complicated is dissipative saturation pdtrans =/= constant -! - if (do_dtrans) then - do k=kph, krefj - tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) - drlee(k) = -tau_src(k)/rho(k) * pdtrans - enddo - endif - - - ENDIF !taulee > 0.0 - - - endif !strver -! - -!========================================================================= - if (strver == 'gfs_2018' .or. strver == 'kd_2005') then -!========================================================================= -! -! orowaves: OGW+DSW/Lee -! - efact = (oa + 2.0) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + clx) ** (oa+1.) - - kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx - kxlinv = coefm * cleff - tem = fr * fr * oc - gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 -!========================================================================= -! source fluxes: taulin, taufrb -!========================================================================= - tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact - - coef_h2 = kxlinv *rhohm * bnv*umag - taulin = coef_h2 *hamp*hamp - hcrit = fcrit_gfs*umag/bnv - tauhcr = coef_h2 *hcrit*hcrit - - IF (fr <= fcrit_gfs) then - tauogw = taulin - tautot = taulin - taulee = 0. - drlee(:) = 0. - ELSE !fr > fcrit_gfs - tauogw = tauhcr - taulee = max(tautot - tauogw, 0.0) - if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) -! approximate drlee(k) between [izb, klwb] -! find klwb and decrease taulee(izb) => taulee(klwb) = 0. -! above izb tau - if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then - - mkz = sqrt(mkz2) - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) - phmkz(:) = 0.0 - klwb = max(izb, 1) - kotr = levs+1 - phmkz(kph-1) = fr ! initial Phase of the Lee-OGW - - loop_lwb_gfs18: do k=kph, levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, velmin*velmin) - mkz2 = bn2i(k)/umd2 - kx2 - if ( mkz2 > mkz2min ) then - mkz = sqrt(mkz2) - frlocal = max(hdsw*bvi(k)/umd(k), frlwb) - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k - else - kotr = k - exit loop_lwb_gfs18 - endif - enddo loop_lwb_gfs18 -! -! - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 - ENDIF !fr > fcrit_gfs - - - ENDIF !strbase='gfs2017' .or. strbase='kd_2005' - - -! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge -! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' -! - end subroutine ugwp_taub_oro -! -!-------------------------------------- -! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, & -! con_pi, con_g, kxw, fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, & -! pmid1, pint1, xn, yn, umag, drtau, kdis_oro) - - subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - pi, grav, kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, xn, yn, umag, drtau, kdis) - - use ugwp_common_v1, only : dw2min, velmin - use cires_ugwp_module_v1, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module_v1, only : kvg, ktg, krad, kion - use ugwp_oro_init_v1, only : coro , fcrit_sm , fcrit_sm2 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - real , dimension(levs+1) :: tau_src - - real, intent(in) :: pi, grav - - real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm - real, dimension(levs+1), intent(in) :: zpi, pmid, pint - real , intent(in) :: xn, yn, umag - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: bnv2min, pi2, rgrav - real :: uref, udir, uf2, ufd, uf2p - real, dimension(levs+1) :: tauz - real, dimension(levs) :: rho - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, kcrit, kref - real :: kx2, kx2w, kxs - real :: mkzm, mkz, dkz, mkz2, ch, kzw3 - real :: wfdM, wfdT, wfiM, wfiT - real :: fdis, mkzi, keff_m, keff_t - real :: betadis, betam, betat, cdfm, cdft - real :: fsat, hsat, hsat2, kds , c2f2 - - pi2 = 2.0*pi - bnv2min = (pi2/1800.)*(pi2/1800.) - rgrav = 1.0/grav - - drtau(1:levs) = 0.0 - kdis (1:levs) = 0.0 - - ch = coro - - kx2w = kxw*kxw - kx2 = kxridge*kxridge - if( kx2 < kx2w ) kx2 = kx2w - kxs = sqrt(kx2) - c2f2 = fcor*fcor/kx2 -! -! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) -! -! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -!=============================================================================== -! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 -! rotational/non-hyrostatic effects are important only for high-res runs -! Udir = 0, Udir < 0 are not -! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz -! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) -! stochastic "tauogw'-setup+ sigma_tau ; -! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves -! target is to get "multiple"-saturation levels for OGWs -!=============================================================================== - tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode - ! sign of tauz > 0...and its attenuate with Z - k = krefj - uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves - uf2 = uref*uref - c2f2 - if (uf2 > 0) then - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2.gt.0) then - mkzm = sqrt(mkz2) - else - return ! wave reflection mkz2 <=0. - endif - else - return ! wave absorption uf2 <= 0. - endif -! -! upward solver for single "mode" with tauz(levs+1) =0. at the top -! - kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer - kcrit = levs - do k= krefj+1, levs -! -! 2D-wave propagation along reference-wind direction -! udir = 0 critical wind for coro =0 -! cdop = -uref .... upwind waves travel against MF -! - udir = ui(k)*xn +vi(k)*yn - uf2 = udir*udir - c2f2 - - - if (uf2 < dw2min .or. udir <= 0.0) then - kcrit =K - tauz(kcrit:levs) = 0. - exit ! vert-level loop - endif -! -! wave-based solution -! - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2 > 0) then - mkzm = sqrt(mkz2) -! -! do dissipative flux vs saturation: kvg, ktg, krad, kion -! - kzw3 = mkzm*mkz2 -! - keff_m = kvg(k)*mkz2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*mkz2 + krad(k) -! -! - uf2p = uf2 + 2.0*c2f2 - betadis = uf2/uf2p - betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw - betaT = 1.0- BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*mkz2 + keff_m - wfiT = kds*mkz2 + keff_t -! - cdfm = sqrt(uf2)*kxs - cdft = abs(udir)*kxs - wfdM = wfiM/cdfm *BetaM - wfdT = wfiT/Cdft *BetaT - mkzi = 2.0*mkzm*(wfdM+wfdT) - - fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) - tauz(k) = fdis - hsat2 = fcrit_sm2 * uf2 *bn2i(k) - fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) - if (fdis > fsat) then - tauz(k) = min(fsat, tauz(k-1)) -!================================================================= -! two definitions for eddy mixing of MF: -! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 -! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 -!================================================================= - kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) - kdis(k) = kds - endif - else - tauz(k:levs) = 0. ! wave is reflected above - kds = 0. - endif - enddo - - do k=krefj+1, kcrit - drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) - enddo -! -! - end subroutine ugwp_oro_lsatdis -! -! - subroutine ugwp_tofd(im, levs, con_cp, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none -! - integer :: im, levs - real(kind_phys) :: con_cp - real(kind_phys), dimension(im, levs) :: u, v, zmid - real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl - real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: rcpd2 - real :: sgh = 30. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 - rcpd2 = 0.5/con_cp -! - - do i=1, im - - zdec = max(n_tofd*sigflt(i), zpbl(i)) - zdec = min(ze_tofd, zdec) - rzdec = 1.0/zdec - sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) - - do k=1, levs - zmet = zmid(i,k) - if (zmet > ztop_tofd) cycle - ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) - umag = sqrt(ekin) - zarg = zmet*rzdec - zexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp - utofd(i,k) = -krf*u(i,k) - vtofd(i,k) = -krf*v(i,k) - epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re - krf_tofd(i,k) = krf - enddo - enddo -! - end subroutine ugwp_tofd -! -! - subroutine ugwp_tofd1d(levs, con_cp, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_oro_init_v1, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none - integer :: levs - real(kind_phys) :: con_cp - real(kind_phys), dimension(levs) :: u, v, zmid - real(kind_phys) :: sigflt, elvmax, zpbl, zsurf - real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: rcpd2 - real :: sghmax = 5. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 - rcpd2 = 0.5/con_cp -! - zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl - zdec = min(ze_tofd, zdec) ! cannot exceed 18 km - rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - - do k=1, levs - zmet = zmid(k)-zsurf - if (zmet > ztop_tofd) cycle - ekin = u(k)*u(k) + v(k)*v(k) - umag = sqrt(ekin) - zarg = zmet*rzdec - ztexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp - - utofd(k) = -krf*u(k) - vtofd(k) = -krf*v(k) - epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re; epstofd(k) can be skipped - krf_tofd(k) = krf - enddo -! - end subroutine ugwp_tofd1d - - -end module cires_vert_orodis_v1 diff --git a/physics/cires_vert_wmsdis.F90 b/physics/cires_vert_wmsdis.F90 deleted file mode 100644 index 9e0bbf37c..000000000 --- a/physics/cires_vert_wmsdis.F90 +++ /dev/null @@ -1,425 +0,0 @@ - subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! -! use para_taub, only : tau_ex - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs - integer :: nw, naz ! # - waves for each azimuth (naz) - integer :: ksrc ! source level - real :: kxw ! horizontal wn - real :: taub_lat ! lat-dep tau_bulk N/m2 -! - real, dimension(nw) :: ch, dch, taub_spect - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - real, dimension(levs+1 ) :: uaz - - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - - real, dimension(levs+1 ) :: taux, tauy, bnrho - real, dimension(levs ) :: dzirho , dzpi - -! - integer :: iaz, k , inc - real, parameter :: gcstar=1.0 - integer , parameter :: nslope=1 - real :: spnorm ! source level normalization factor for the Broad Spectra - real :: bnrhos ! sum(taub_spect*dc) = spnorm taub_sect_norm = taub_spect/spnorm -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - bnrhos = bvi(ksrc)/rhoi(ksrc) - do k=1,levs - dzpi(k) = zint(k+1)-zint(k) - dzirho(k) = 1.0 / (rho(k)*dzpi(k)) ! grav/abs(dp(k)) still hydrostatic "ugwp" - bnrho(k) = (rhoi(k)/bvi(k)) !*bnrhos * gcstar ! gcstar=1.0 and bnrho(k=ksrc) =1. - enddo - k = levs+1 - bnrho(k) = (rhoi(k)/bvi(k))*bnrhos -! -! re-define ch, dch, taub_spect, this portion can be moved to "ugwp_init" -! -! -! - call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) - - -! print *, ' after FVS93_ugwp ', nw, maxval(ch), minval(ch) -! -! do normaalization for the spectral element of the saturated flux -! - bnrho = bnrho *spnorm - -! print * -! do inc=1, nw -! write(6,221) inc, ch(INC),taub_lat*taub_spect(inc), spnorm, dch(inc) -!221 FORMAT( i6, 2x, F8.2, 3(2x, E10.3)) -! enddo -! pause - - loop_iaz: do iaz =1, naz - - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) - enddo -! -! -! multi-wave broad spectrum of FVS-93 with ~scheme of WMS-IFS 2010 -! -! print *, ' iaz before ugwp_wmsdis_az1 ', iaz -! - - call ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_spect, taub_lat, & - spnorm, fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, bnrho, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - -! print *, ' iaz after ugwp_wmsdis_az1 ', iaz - -! - enddo loop_iaz ! azimuth of gw propagation directions -! -! sum over azimuth and project atau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum( kedd(k,:)) - enddo -! - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) - -! end solver: gw_azimuth_solver_ls81 -! sign ax in rho*du/dt = -d(rho*tau)/dz -! [(k) - (k+1)] -! du/dt = ax = -1/rho*d( tau) /dz -! - ax =0. ; ay = 0. - - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - - return - end subroutine ugwp_wmsdis_naz - - -! ======================================================================= - subroutine ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_sp, tau_bulk, & - spnorm, fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, bnrho, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) -! -! use para_taub, only : tau_ex, xlatdeg !for exchange src-tau -! - use cires_ugwp_module, only : f_coriol, f_nonhyd, f_kds, linsat - use cires_ugwp_module, only : ipr_ktgw, ipr_spgw, ipr_turb, ipr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! ======================================================================= - integer :: levs, ksrc, nw - real :: fcor, c2f2, kxw -! - real, dimension(nw) :: taub_sp, ch, dch - real :: tau_bulk, spnorm - real, dimension(levs) :: zm, rho, dzirho, dzpi - real, dimension(levs+1) :: zi, um, tm, bn2, bn, rhoi, bnrho - real, dimension(levs+1) :: kvg, ktg, krad, kion, kmol - real, dimension(levs+1) :: ked, tau - real, dimension(levs ) :: eps -! -!locals - integer :: k, inc - real, dimension(levs+1) :: umi - real :: zcin, zci_min, ztmp, zcinc - real :: zcimin=0.5 ! crit-level precision, 0.5 and start of Ch_MIN - real, parameter :: Keff = 0.2 - - real, dimension(nw) :: zflux ! - real, dimension(nw) :: wzact, zacc ! =1 ..crit level change it - - real, dimension(levs) :: zcrt ! - real, dimension(nw, levs) :: zflux_z, zact - - real :: zdelp, kxw2 - real :: vu_eff, vu_lin, v_kzw, v_cdp, v_wdp, v_kzi - real :: dfsat, fdis, fsat, fmode, expdis - real :: vc_zflx_mode, vm_zflx_mode - real :: tau_g5 -! ======================================================================= -!eps, ked, tau - - eps (:) =0; ked = 0.0 ; - kxw2 = kxw*kxw -! - zcrt(1:levs) = 0.0 - umi(1:levs+1) = um -! umi(1:levs+1) = um(1:levs+1) -um(ksrc) - - zci_min = zcimin - -! CALL slat_geos5(1, xlatdeg(1), tau_g5) -! tau_bulk = tau_g5 !tau_bulk*0.75 !3.75e-2 -! - zflux(:) = taub_sp(:)*tau_bulk ! includes tau_bulk(x,y) and spectral normalization - - zflux_z(1:nw,ksrc)=zflux(:) - - tau(1:levs+1) = tau_bulk ! constant flux for all layers k0.0 ) then -! ztmp = sum( ch(:)*zacc(:)*zflux(:)*dch(:) ) -! zcrt(k)=ztmp/tau(k) -! else -! zcrt( k )=zcrt(k-1) -! endif -! --------------------------------------------------------- -! do saturation (eq. (26) and (27) of scinocca 2003) -! + add molecular/eddy dissipation od gw-spectra vay-2015 -! for each mode & direction -! x by exp(-mi*zdelp) x introduce ....... mi(nw) -! -! mode-loop + add molecular/eddy dissipation od gw-spectra vay-2015 -! - do inc=1,nw - if (zact(inc,k) == 0.0) then - zflux(inc) = 0.0 - zflux_z(inc,k) = zflux(inc) - else - vu_eff = kvg(k) ! + ktg (k) !* ipr_ktgw - vu_lin = kion(k) ! + krad(k) !* ipr_ktgw - vu_eff = 2.e-5*exp(zi(k)/7000.)+.01 - zcin= ch(inc) - -!======================================================================= -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= - v_cdp = zcin-umi(k) - v_wdp = kxw*v_cdp - if (v_wdp.gt.0) then - v_kzw = bn(k)/v_cdp !can be non-hydrostatic - v_kzi = abs(( v_kzw*v_kzw*vu_eff + vu_lin) /v_wdp*v_kzw) - expdis = exp(-2.*v_kzi*dzpi(k) ) - else - v_kzi = 0. - expdis = 1.0 - endif - fmode = zflux(inc) - fdis = fmode*expdis ! only dissipation/crit_lev degrades it -!------------------------ -! includes rho/bn /(rhos/bns) *spnorm -!------------------------ - fsat = bnrho(k)* v_cdp*v_cdp /zcin ! expression for saturated flux - ! zfluxs=gcstar*zfct( k)*(zcin-zui( k ))**2/zcin -! flux_tot - sat.flux -! - dfsat= fdis-fsat - if( dfsat > 0.0 ) then -! put sat-n limit - zflux(inc) = fsat - else -! assign dis-ve flux - zflux(inc) =fdis - endif - zflux_z(inc,k)=zflux(inc) - - if (zflux_z(inc,k) > zflux_z(inc,k-1) ) zflux_z(inc,k) = zflux_z(inc,k-1) - - endif - - enddo -! -! integrate over spectral modes zpu(y, z, azimuth) zact( inc, )*zflux( inc, )*[d("zcinc")] -! - tau(k) = sum( zflux_z(:,k)*dch(:)) -!------------------------------------------------------------------------------ -! define expressions for eps-heat + Ked, needs more work for the broad spectra -! formulation especially for Ked -! after defining Ked .....GW-eddy cooling needs to be added -! for now "only" heating here -!============================================================================== - eps(k) =0. - do inc=1, nw - if (zact(inc,k) == 0.0) cycle ! dc-integration + dtau/dz - vc_zflx_mode = zflux(inc) - - zdelp= abs(ch(inc)-umi(k)) * dch(inc) /dzpi(k) - vm_zflx_mode=zflux_z(inc,k-1) - eps(k) =eps( k ) + (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - - - enddo !inc=1, nw - ked(k) = Keff*eps(k)/bn2(k) -! -! -------------- -! - enddo ! end k do-loop vertical loop do k=ksrc+1, levs - -!top lid - k =levs+1 - ked(k) = ked(k-1) -! eps(k) = eps(k-1) - tau(k) =tau(k-1)*0.933 - -! from surface to ksrc-1 -! tau(1:ksrc) = tau(ksrc) - ked(1:ksrc) = 0. - eps( 1:ksrc) = 0. - -! -! output: eps, ked, tau for given azimuth -! - end subroutine ugwp_wmsdis_az1 -! -! - subroutine FVS93_ugwps(nw, ch, dch, taub_sp, spnorm, nslope, bn2, bn, bnrhos) - implicit none - integer :: nw, nslope - real :: bn2, bn, bnrhos -!! real :: taub_lat ! bulk - lat-dep momentum flux - real, dimension (nw) :: ch, dch, taub_sp -! locals - integer :: i, inc - real, parameter :: zcimin = 0.5, zcimax = 95.0, zgam =1./4. - real, parameter :: zms = 6.28e-3/2. ! mstar Lz ~ 2km - real :: zxran, zxmax, zxmin, zx1, zx2, zdx, ztx, rch - real :: bn3, bn4, zcin, tn4, tn3, tn2, cstar - real :: spnorm ! needs to be passed for saturation flux norm-n - real :: tau_bulk -!-------------------------------------------------------------------- -! -! transforms ch -uniform => 1/ch and back to non-uniform ch, dch -! -!------------------------------------------------------------------- -! note that this is expresed in terms of the intrinsic ch or vertical wn=N/cd -! at launch cd=ch-um(ksrc), the transformation is identical for all -! levels, azimuths and horizontal pixels -! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform -! - zxmax=1.0 /zcimin - zxmin=1.0 /zcimax - zxran=zxmax-zxmin - zdx=zxran/float(nw-1) ! d_kz or d_mi -! -! - zx1=zxran/(exp(zxran/zgam)-1.0 ) !zgam =1./4. - zx2=zxmin-zx1 -! -! add idl computations for zci =1/zx -! x = 1/c stretching transform to look at final ch(i), dch(i) -! - - do i=1, nw - ztx=float(i-1)*zdx+zxmin - rch=zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 - ch(i)=1.0 /rch !eq. 28 of scinocca 2003 - dch(i)=ch(i)*ch(i)*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 - enddo -! -! nslope-dependent flux taub_spect(nw) momentum flux spectral density -! need to check math....expressions -! eq. (25) of scinocca 2003 with u-uo=0 it is identical to all azimuths -! -! - cstar=bn/zms - bn4=bn2*bn2 ! four times - bn3=bn2*bn - if(nslope==1) then -! s=1 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc) =bnrhos * zcin*bn4/(bn4+tn4) - enddo -! - elseif(nslope==2) then -! s=2 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc)= bnrhos*zcin*bn4/(bn4+tn4*zcin/cstar) - enddo -! - elseif(nslope==-1) then -! s=-1 case - do inc=1, nw - zcin=ch(inc) - tn2=(zms*zcin)**2 - taub_sp(inc)=bnrhos*zcin*bn2/(bn2+tn2) - enddo -! s=0 case - elseif(nslope==0) then - - do inc=1, nw - zcin=ch(inc) - tn3=(zms*zcin)**3 - taub_sp(inc)=bnrhos*zcin*bn3/(bn3+tn3) - enddo - endif ! for n-slopes -!============================================= -! normalize launch momentum flux -! ------------------------------------ -! (rho x f^h = rho_o x f_p^total) integrate (zflux x dx) - - tau_bulk= sum(taub_sp(:)*dch(:)) - spnorm= 1./tau_bulk - - do inc=1, nw - taub_sp(inc)=spnorm*taub_sp(inc) - enddo - - end subroutine FVS93_ugwps - diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index c47079992..abb78e7a6 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,266 +1,3 @@ -! - module sso_coorde -! -! specific to COORDE-2019 project OGW switches/sensitivity -! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) -! pgd4=4 (4 timse taub, control pgwd=1) -! - use machine, only: kind_phys - real(kind=kind_phys),parameter :: pgwd = 1.0_kind_phys - real(kind=kind_phys),parameter :: pgwd4 = 1.0_kind_phys - logical, parameter :: debugprint = .false. - end module sso_coorde -! -! -! Routine cires_ugwp_driver_v0 is replaced with cires_ugwp.F90/cires_ugwp_run in CCPP -#if 0 - subroutine cires_ugwp_driver_v0(me, master, - & im, levs, nmtvr, dtp, kdt, imx, do_ugwp, do_tofd, - & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, - & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, - & phii, phil, del, hprime, oc, oa4, clx, theta, - & gamm, sigma, elvmax, sgh30, kpbl, - & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, - & tau_tofd, tau_mtb, tau_ogw, tau_ngw, - & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, - & rain, ntke, tke, lprnt, ipr) -!----------------------------------------------------------- -! Part 1 "old-revised" gfs-gwdps_v0 or "old" gwdps (if do_ugwp=.false.) -! Part 2 non-stationary multi-wave GWs FV3GFS-v0 -! Part 3 Dissipative version of UGWP-tendency application -! (similar to WAM-2017) -!----------------------------------------------------------- - use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv, & - con_omega - - use ugwp_wmsdis_init, only : tamp_mpa, ilaunch - use sso_coorde, only : pgwd, pgwd4, debugprint - implicit none -!input - - integer, parameter :: kp = kind_phys - - integer, intent(in) :: me, master - integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr - - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) - logical :: do_ugwp, do_tofd, lprnt - integer, intent(in) :: kpbl(im) - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd - &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area - &, rain - - real(kind=kind_phys), intent(in), dimension(im,levs) :: - &, ugrs, vgrs, tgrs, qgrs, prsl, prslk, phil, del - real(kind=kind_phys), intent(in), dimension(im,levs+1) :: - & phii, prsi - -! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) - real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc - &, theta, gamm, sigma, elvmax - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4, clx - real(kind=kind_phys), intent(in) :: tke(im,levs) -!out - real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt - &, gw_dTdt, gw_kdis - -!-----locals + diagnostics output - - real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt - &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt - - real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg - - real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, - & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw, turb_fac - real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw - &, du3dt_tms - real(kind=kind_phys), dimension(im) :: tem - -! locals - real(kind=kind_phys) :: rfac, tx1 - integer :: i, j, k, ix -! -! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax -! -! real(kind=kind_phys), dimension(im) :: hprime, -! & oc, theta, sigma, gamm, elvmax -! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 -! -! switches that activate impact of OGWs and NGWs along with eddy diffusion -! - real(kind=kind_phys), parameter :: pogw=1.0_kp, pngw=1.0_kp - &, pked=1.0_kp, zero=0.0_kp - &, ompked=1.0_kp-pked -! -! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS execute ugwp_driver_v0 ' -! write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr - write(6,*) ' COORDE EXPER pogw = ' , pogw - write(6,*) ' COORDE EXPER pgwd = ' , pgwd - write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 - print * - endif - - do i=1,im - zlwb(i) = zero - enddo -! -! 1) ORO stationary GWs -! ------------------ - - if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag - CALL GWDPS_V0(IM, levs, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, - & ugrs , vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, - & prslk, phii, phil, DTP,KDT, - & sgh30, HPRIME, OC, OA4, CLX, THETA, - & SIGMA, GAMM, ELVMAX, - & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, - & cdmbgwd(1:2), me, master, rdxzb, - & con_g, con_omega, - & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, - & du3dt_mtb, du3dt_ogw, du3dt_tms) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' - print * - endif - else ! calling old GFS gravity wave drag as is - do k=1,levs - do i=1,im - pdvdt(i,k) = zero - pdudt(i,k) = zero - pdtdt(i,k) = zero - pkdis(i,k) = zero - enddo - enddo - if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero) then - call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & - &, ugrs, vgrs, tgrs, qgrs & - &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& - &, hprime, oc, oa4, clx, theta, sigma, gamm & - &, elvmax, dusfcg, dvsfcg & - &, con_g, con_cp, con_rd, con_rv, imx & - &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) - endif - - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - endif -! - if (cdmbgwd(3) > zero) then -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) - -! call slat_geos5(im, xlatd, tau_ngw) -! - if (abs(1.0_kp-cdmbgwd(3)) > 1.0e-6_kp) then - if (cdmbgwd(4) > zero) then - do i=1,im - turb_fac(i) = zero - tem(i) = zero - enddo - if (ntke > 0) then - do k=1,(levs+levs)/3 - do i=1,im - turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) - tem(i) = tem(i) + del(i,k) - enddo - enddo - do i=1,im - turb_fac(i) = turb_fac(i) / tem(i) - enddo - endif - rfac = 86400000 / dtp - do i=1,im - tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1_kp, min(5.0_kp, tx1)) - enddo - endif - do i=1,im - tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) - enddo - endif -! - call fv3_ugwp_solv2_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, prsl, prsi, - & phil, xlatd, sinlat, coslat, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - endif - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - gw_dtdt(i,k) = Pdtdt(i,k) - gw_dudt(i,k) = Pdudt(i,k) - gw_dvdt(i,k) = Pdvdt(i,k) - gw_kdis(i,k) = Pkdis(i,k) - enddo - enddo - endif - - if (pogw == zero) then -! zmtb = 0.; zogw =0. - tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero - du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero - endif - - return - -!============================================================================= -! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving -! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" -!============================================================================= -! -! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies -!------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = zero ; ed_dvdt(i,k) = zero ; ed_dtdt(i,k) = zero - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, del, - & prsl, prsi, phil, prslk, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) - - do k=1,levs - do i=1,im - gw_dtdt(i,k) = gw_dtdt(i,k)*ompked + ed_dtdt(i,k)*pked - gw_dvdt(i,k) = gw_dvdt(i,k)*ompked + ed_dvdt(i,k)*pked - gw_dudt(i,k) = gw_dudt(i,k)*ompked + ed_dudt(i,k)*pked - enddo - enddo - - end subroutine cires_ugwp_driver_v0 -#endif ! !===================================================================== ! @@ -301,12 +38,12 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, !---------------------------------------- USE MACHINE , ONLY : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 + use ugwp_common_v0,only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 &, pi, rad_to_deg, deg_to_rad, pi2 &, rdi, gor, grcp, gocp, fv, gr2 &, bnv2min, dw2min, velmin, arad - use ugwp_oro_init, only : rimin, ric, efmin, efmax + use ugwpv0_oro_init, only : rimin, ric, efmin, efmax &, hpmax, hpmin, sigfaci => sigfac &, dpmin, minwnd, hminmt, hncrit &, RLOLEV, GMAX, VELEPS, FACTOP @@ -315,11 +52,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, &, cdmb, cleff, fcrit_gfs, fcrit_mtb &, n_tofd, ze_tofd, ztop_tofd - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - use sso_coorde, only : pgwd, pgwd4, debugprint + use cires_ugwpv0_module, only : kxw, max_kdis, max_axyz + !---------------------------------------- implicit none - integer, parameter :: kp = kind_phys + integer, parameter :: kp = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -452,22 +189,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! sigmin = 2.*hpmin/dsmax !dxres ! Moorthi - this will not reproduce sigmin = 2.*hpmin/dxres !dxres -! if (kdt == 1) then -! print *, sgrmax, sgrmin , ' min-max sparea ' -! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax -! print *, 'dxres/dsmax ', dxres, dsmax -! print *, ' shilmin gammin ', shilmin, gammin -! endif - kxridge = float(IMX)/arad * cdmbgwd(2) - if (me == master .and. kdt == 1 .and. debugprint) then - print *, ' gwdps_v0 kxridge ', kxridge - print *, ' gwdps_v0 scale2 ', cdmbgwd(2) - print *, ' gwdps_v0 IMX ', imx - print *, ' gwdps_v0 GAM_MIN ', gammin - print *, ' gwdps_v0 SSO_MIN ', sso_min - endif + kxridge = float(IMX)/arad * cdmbgwd(2) do i=1,im idxzb(i) = 0 @@ -543,9 +267,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, endif enddo - IF (npt == 0 .and. debugprint) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin + IF (npt == 0) then RETURN ! No gwd/mb calculation done endif @@ -918,16 +640,16 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, kxridge = 1.0 / sqrt(sparea(J)) XLINV(I) = XLINGFS !or max(kxridge, inv_b2eff) ! 6.28/Lx ..0.5*sigma(j)/heff = 1./Lridge taulin(i) = 0.5*ROLL(I)*XLINV(I)*BNV*ULOW(I)* - & heff*heff*pgwd4 + & heff*heff if ( FR > fcrit_gfs ) then TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 ! nonlinear FLUX Tau0...XLINV(I) + & * ULOW(I) * GFOBNV * EFACT ! nonlinear FLUX Tau0...XLINV(I) ! else ! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 + & * ULOW(I) * GFOBNV * EFACT ! ! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs ! @@ -1083,9 +805,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! --------------------------- IF( do_tofd ) then axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0 .and. debugprint) then - print *, 'VAY do_tofd from surface to ', ztop_tofd - endif + + DO I = 1,npt J = ipt(i) zpbl =rgrav*phil( j, kpbl(j) ) @@ -1099,8 +820,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, vp1(k) = v1(j,k) enddo - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, - & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) + call ugwpv0_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, + & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) do k=1,km axtms(j,k) = utofd1(k) @@ -1151,8 +872,8 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! OGW-s above blocking height ! TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) * pgwd - DTAUY = TAUD(I,K) * YN(I) * pgwd + DTAUX = TAUD(I,K) * XN(I) + DTAUY = TAUD(I,K) * YN(I) Pdvdt(j,k) = DTAUY +Pdvdt(j,k) Pdudt(j,k) = DTAUX +Pdudt(j,k) @@ -1185,97 +906,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, RETURN - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0 .and. debugprint) then - print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' -! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' - print *, maxval(pdTdt)*86400., minval(pdTdt)*86400,'vgw_epsoro' - print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' - print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' -! print *, maxval(tau_tofd), ' tau_tofd ' -! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' -! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' - if (maxval(abs(pdudt))*86400. > 100.) then - - print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' - print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' - print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' - print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' - print *, maxval(del), minval(del), ' del gwdps-v0 ' - print *, maxval(phil)*rgrav,minval(phil)*rgrav, 'zmet' - print *, maxval(phii)*rgrav,minval(phii)*rgrav, 'zmeti' - print *, maxval(prsi), minval(prsi), ' prsi ' - print *, maxval(prsL), minval(prsL), ' prsL ' - print *, maxval(RO), minval(RO), ' RO-dens ' - print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' BNV2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' - print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' - print * - do i =1, npt - j= ipt(i) - print *,zogw(J)/hprime(j), zmtb(j)/hprime(j), - & phil(j,1)/9.81, nint(hprime(j)/sigma(j)) -! -!.................................................................... -! -! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m -! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km -! we must exclude blocking by small ridges -! VAY-kref < iblk zogw-lev 15 block-level: 39 -! -! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters -! MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) -! MAX(DW2,DW2MIN) * RDZ * RDZ -! ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) -! TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.1) -! TEMV = 1.0 / max(VELCO(I,K), 0.01) -! & * max(VELCO(I,K),0.01) -!.................................................................... - enddo - print * - stop - endif - endif - -! - RETURN -!--------------------------------------------------------------- -! review of OLD-GFS code 2017/18 most substantial changes -! a) kref > idxzb if idxzb > KPBL "OK" clipped-hill for OGW -! b) tofd -sgh30 "OK" -! -! c) FR < Frc linear theory for taub-specification -! -! d) solver of Palmer et al. (1987) => Linsat of McFarlane -! -!--------------------------------------------------------------- end subroutine gwdps_v0 !=============================================================================== -! use fv3gfs-v0 -! first beta version of ugwp for fv3gfs-128 -! cires/swpc - jan 2018 -! non-tested wam ugwp-solvers in fv3gfs: "lsatdis", "dspdis", "ado99dis" -! they reqiure extra-work to put them in with intializtion and namelists -! next will be lsatdis for both fv3wam & fv3gfs-128l implementations -! with (a) stochastic-deterministic propagation solvers for wave packets/spectra -! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) -! (c) guidance from high-res runs for GW sources and res-aware tune-ups -!23456 -! -! call gwdrag_wam(1, im, ix, km, ksrc, dtp, -! & xlat, gw_dudt, gw_dvdt, taux, tauy) -! call fv3_ugwp_wms17(kid1, im, ix, km, ksrc_ifs, dtp, -! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, -! & taux,tauy,grav, amol_i, me, lstep_first ) -! -! !23456============================================================================== !>\ingroup cires_ugwp_run @@ -1297,21 +932,19 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv + use ugwp_common_v0 , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv &, rad_to_deg, deg_to_rad &, rdi, gor, grcp, gocp &, bnv2min, dw2min, velmin, gr2 ! - use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec + use ugwpv0_wmsdis_init, only : hpscale, rhp2, bv2min, gssec &, v_kxw, v_kxw2, tamp_mpa, zfluxglob &, maxdudt, gw_eff, dked_min &, nslope, ilaunch, zmsi &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang - &, nwav, nazd, zcimin, zcimax - - use sso_coorde, only : debugprint + &, nwav, nazd, zcimin, zcimax ! implicit none !23456 @@ -1426,26 +1059,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, phil(j,k) = philg(j,k) * rgrav enddo enddo -!----------------------------------------------------------- -! also other options to alter tropical values -! tamp = 100.e-3*1.e3 = 100 mpa -! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 -!----------------------------------------------------------- -! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) - -! phil = philg*rgrav - -! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] -! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp - - if (kdt ==1 .and. mpi_id == master .and. debugprint) then - print *, maxval(tm1), minval(tm1), 'vgw: temp-res ' - print *, 'ugwp-v0: zcimin=' , zcimin - print *, 'ugwp-v0: zcimax=' , zcimax - print * - endif -! !================================================= do iazi=1, nazd do jk=1,klev @@ -1589,7 +1203,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo - endif ! for slopes + endif ! for slopes ! ! normalize momentum flux at the src-level ! ------------------------------ @@ -1866,257 +1480,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! !--------------------------------------------------------------------------- -! - if (kdt == 1 .and. mpi_id == master .and. debugprint) then - print *, 'vgw done ' -! - print *, maxval(pdudt)*86400, minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400, minval(pdvdt)*86400, 'vgw ay' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400, minval(pdtdt)*86400,'vgw eps' -! -! print *, ' ugwp -heating rates ' - endif - return end subroutine fv3_ugwp_solv2_v0 -!------------------------------------------------------------------------------- -! -! Part-3 of UGWP-V01 Dissipative (eddy) effects of UGWP it will be activated -! after tests of OGW (new revision) and NGW with MERRA-2 forcing. -! -!------------------------------------------------------------------------------- - subroutine edmix_ugwp_v0(im, levs, dtp, - & t1, u1, v1, q1, del, - & prsl, prsi, phil, prslk, - & pdudt, pdvdt, pdTdt, pkdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) -! - use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rdi, fv -! &, pi, rad_to_deg, deg_to_rad, pi2 - &, bnv2min, velmin, arad - - implicit none - - integer, intent(in) :: me, master, kdt - integer, intent(in) :: im, levs - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in), dimension(im,levs) :: - & u1, v1, t1, q1, del, prsl, prslk, phil -! - real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi - real(kind=kind_phys),dimension(im,levs) :: pdudt, pdvdt, pdTdt - real(kind=kind_phys),dimension(im,levs) :: pkdis -! -! out -! - real(kind=kind_phys),dimension(im,levs) :: ed_dudt, ed_dvdt - real(kind=kind_phys),dimension(im,levs) :: ed_dTdt -! -! locals -! - integer :: i, j, k -!------------------------------------------------------------------------ -! solving 1D-vertical eddy diffusion to "smooth" -! GW-related tendencies: du/dt, dv/dt, d(PT)/dt -! we need to use sum of molecular + eddy terms including turb-part -! of PBL extended to the model top, because "phys-tend" dx/dt -! should be smoothed as "entire" fields therefore one should -! first estimate and collect "effective" diffusion and applied -! it to each part of tendency or "sum of tendencies + Xdyn" -! this "diffusive-way" is tested with UGWP-tendencies -! forced by various wave sources. X' =dx/dt *dt -! d(X + X')/dt = K*diff(X + X') => -! -! wave1 dX'/dt = Kw * diff(X')... eddy part "Kwave" on wave-part -! turb2 dX/dt = Kturb * diff(X) ... resolved scale mixing "Kturb" like PBL -! we may assume "zero-GW"-tendency at the top lid and "zero" flux -! or "vertical gradient" near the surface -! -! 1-st trial w/o PBL interactions: add dU, dV dT tendencies -! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " -! ed_X = X_ed - X => final eddy tendencies -!--------------------------------------------------------------------------- -! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) -! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp -! - real(kind=kind_phys) :: Sw(levs), Sw1(levs), Fw(levs), Fw1(levs) - real(kind=kind_phys) :: Km(levs), Kpt(levs), Pt(levs), Ptmap(levs) - real(kind=kind_phys) :: rho(levs), rdp(levs), rdpm(levs-1) - real(kind=kind_phys),dimension(levs) :: ktur, vumol, up, vp, tp - real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum - real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis - real(kind=kind_phys) :: rdz , uz, vz, ptz -! ------------------------------------------------------------------------- -! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt -! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) -! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit -! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 -! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 -! - real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 - real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb - real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb - real(kind=kind_phys), parameter :: ric =0.25 - real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 - real(kind=kind_phys), parameter :: prmax = 4.0 - real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps - real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. - - - real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur - integer :: nstab - real(kind=kind_phys) :: w1, w2, w3 - rdtp = 1./dtp - nstab = 1 - stab_dt = 0.9999 - - do i =1, im - - rdp(1:levs) = grav/del(i, 1:levs) - - up(1:levs) = u1(i,1:levs) +pdudt(i,1:levs)*dtp - vp(1:levs) = v1(i,1:levs) +pdvdt(i,1:levs)*dtp - tp(1:levs) = t1(i,1:levs) +pdTdt(i,1:levs)*dtp - Ptmap(1:levs) = (1.+fv*q1(i,1:levs))/prslk(i,1:levs) - rho(1:levs) = rdi*prsl(i, 1:levs)/tp(1:levs) - Pt(1:levs) = tp(1:levs)*Ptmap(1:levs) - - do k=1, levs-1 - rdpm(k) = grav/(prsl(i,k)-prsl(i,k+1)) - rdz = .5*rdpm(k)*(rho(k)+rho(k+1)) - uz = up(k+1)-up(k) - vz = vp(k+1)-vp(k) - ptz =2.*(pt(k+1)-pt(k))/(pt(k+1)+pt(k)) - shr2(k) = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - bn2(k) = grav*rdz*ptz - zmet = phil(j,k)*rgrav - zgrow = exp(zmet*h4) - if ( bn2(k) < 0. ) then -! -! adjust PT-profile to bn2(k) = bnv2min -- neutral atmosphere -! adapt "pdtdt = (Ptadj-Ptdyn)/Ptmap" -! -! print *,' UGWP-V0 unstab PT(z) via gwdTdt ', bn2(k), k - - rineg = bn2(k)/shr2(k) - bn2(k) = max(bn2(k), bnv2min) - kamp = sqrt(shr2(k))*sc2u *zgrow - ktur(k) =kamp* (1+8.*(-rineg)/(1+1.746*sqrt(-rineg))) - endif - ritur = max(bn2(k)/shr2(k), rimin) - if (ritur > 0. ) then - kamp = sqrt(shr2(k))*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur(k)= kamp * w1 * w1 - endif - vumol(k) = 2.e-5 *exp(zmet/hps) - ksum(k) =ktur(k)+Pkdis(i,k)+vumol(k) - ksum(k) = max(ksum(k), kedmin) - ksum(k) = min(ksum(k), kedmax) - stab = 2.*ksum(k)*rdz*rdz*dtp - if ( stab >= 1.0 ) then - stab_dt = max(stab_dt, stab) - endif - enddo - nstab = max(1, nint(stab_dt)+1) - dtstab = dtp / float(nstab) - ksum(levs) = ksum(levs-1) - Fw(1:levs) = pdudt(i, 1:levs) - Fw1(1:levs) = pdvdt(i, 1:levs) - Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) - - do j=1, nstab - call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, - & rdp, rdpm, Sw, Sw1) - Fw = Sw - Fw1 = Sw1 - enddo - - ed_dudt(i,:) = Sw - ed_dvdt(i,:) = Sw1 - - Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) - Kpt = Km*iPr_pt - Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) - do j=1, nstab - call diff_1d_ptend(levs, dtstab, Fw, Kpt, rdp, rdpm, Sw) - Fw = Sw - enddo - ed_dtdt(i,1:levs) = Sw(1:levs)/Ptmap(1:levs) - - enddo - - end subroutine edmix_ugwp_v0 - subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! S(:) = 0.0 ; S1(:) = 0.0 -! -! explicit diffusion solver -! - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. - cd - ad -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - S1(K) = F1(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) - enddo - k = levs - S(k) = F(k) - S1(k) = F1(k) - end subroutine diff_1d_wtend - - subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! -! explicit "eddy" smoother for tendencies -! - - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. -(cd +ad) -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - enddo - k = levs - S(k) = F(k) - end subroutine diff_1d_ptend + diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 20ab38897..4439845ad 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -1,8 +1,9 @@ !> \file ugwpv1_gsldrag.F90 -!! This file combines three gravity wave drag schemes under one ("ugwpv1_gsldrag") suite: -!! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: -!! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f -!! b) the v0 cires ugwp non-stationary GWD scheme +!! This introduces two gravity wave drag schemes ugwpv1/CIRES and GSL/drag_suite.F90 under "ugwpv1_gsldrag" suite: +!! 1) The "V1 CIRES UGWP" scheme as tested in the FV3GFSv16-127L atmosphere model and workflow, which includes: +!! a) the orograhic gravity wave drag, flow blocking scheme and TOFD (Beljaars et al, 2004). +!! b) the v1 CIRE ugwp non-stationary GW scheme, new revision that generate realistic climate of FV3GFS-127L +!! in the strato-mesosphere in the multi-year simulations (Annual cycles, SAO and QBO in th tropical dynamics). !! 2) The GSL orographic drag suite (drag_suite.F90), as implmeneted in the RAP/HRRR, which includes: !! a) large-scale gravity wave drag and low-level flow blocking -- active at horizontal scales !! down to ~5km (Kim and Arakawa, 1995 \cite kim_and_arakawa_1995; Kim and Doyle, 2005 \cite kim_and_doyle_2005) @@ -10,8 +11,7 @@ !! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) !! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km !! (Beljaars et al, 2004 \cite beljaars_et_al_2004) -!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) -!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: +!! See Valery Yudin's presentation at 2020 UFS User's meeting (Jul 2020): !! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers !! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics !! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. @@ -172,7 +172,7 @@ subroutine ugwpv1_gsldrag_init ( & print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & - support but has Logic error" + support with but has Logic error" errflg = 1 return endif @@ -341,9 +341,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Preference use (im,levs) rather than (:,:) to avoid memory-leaks ! that found in Nov-Dec 2020 ! order array-description control-logical -! other in-variables -! out-variables -! local-variables +! other in-variables +! out-variables +! local-variables ! ! unified GSL and CIRES diagnostics inside CCPP and GFS_typedefs.F90/GFS_diagnostics.F90 ! @@ -453,7 +453,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init ! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa ! -! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 +! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 !------------ ! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 @@ -532,8 +532,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd - if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd & - .or. do_ugwp_v1_w_gsldrag) then + if ( do_gsl_drag_ls_bl.or.do_gsl_drag_ss.or.do_gsl_drag_tofd) then ! ! to do: the zero diag and tendency values assigned inside "drag_suite_run" can be skipped : ! @@ -581,7 +580,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd else ! -! not gsldrag scheme for example "do_ugwp_v1_orog_only" +! not gsldrag oro-scheme for example "do_ugwp_v1_orog_only" ! if ( do_ugwp_v1_orog_only ) then @@ -634,9 +633,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - ENDIF ! + ENDIF ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Begin non-stationary GW schemes ! ugwp_v1 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 8f8538077..b6bd83d2c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -1,5 +1,5 @@ !> \file unified_ugwp.F90 -!! This file combines three gravity wave drag schemes under one ("unified_ugwp") suite: +!! This file combines three two orographic GW-schemes cires_ugwp.F90 and drag_suite.F90 under "unified_ugwp" suite: !! 1) The "V0 CIRES UGWP" scheme (cires_ugwp.F90) as implemented in the FV3GFSv16 atmosphere model, which includes: !! a) the "traditional" EMC orograhic gravity wave drag and flow blocking scheme of gwdps.f !! b) the v0 cires ugwp non-stationary GWD scheme @@ -10,8 +10,6 @@ !! (Steeneveld et al, 2008 \cite steeneveld_et_al_2008; Tsiringakis et al, 2017 \cite tsiringakis_et_al_2017) !! c) turbulent orographic form drag -- active at horizontal grid ersolutions down to ~1km !! (Beljaars et al, 2004 \cite beljaars_et_al_2004) -!! 3) The "V1 CIRES UGWP" scheme developed by Valery Yudin (University of Colorado, CIRES) -!! See Valery Yudin's presentation at 2017 NGGPS PI meeting: !! Gravity waves (GWs): Mesoscale GWs transport momentum, energy (heat) , and create eddy mixing in the whole atmosphere domain; Breaking and dissipating GWs deposit: (a) momentum; (b) heat (energy); and create (c) turbulent mixing of momentum, heat, and tracers !! To properly incorporate GW effects (a-c) unresolved by DYCOREs we need GW physics !! "Unified": a) all GW effects due to both dissipation/breaking; b) identical GW solvers for all GW sources; c) ability to replace solvers. @@ -29,8 +27,6 @@ !! do_gsl_drag_ls_bl -- activates RAP/HRRR (GSL) large-scale GWD and blocking !! do_gsl_drag_ss -- activates RAP/HRRR (GSL) small-scale GWD !! do_gsl_drag_tofd -- activates RAP/HRRR (GSL) turbulent orographic drag -!! do_ugwp_v1 -- activates V1 CIRES UGWP scheme - both orographic and non-stationary GWD -!! do_ugwp_v1_orog_only -- activates V1 CIRES UGWP scheme - orographic GWD only !! Note that only one "large-scale" scheme can be activated at a time. !! @@ -38,22 +34,12 @@ module unified_ugwp use machine, only: kind_phys - use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize - - use cires_ugwp_module_v1, only: cires_ugwp_init_v1, cires_ugwp_finalize, calendar_ugwp - +! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run use drag_suite, only: drag_suite_run - use cires_ugwp_orolm97_v1, only: gwdps_oro_v1 - - use cires_ugwp_triggers_v1, only: slat_geos5_tamp_v1 - - ! use cires_ugwp_ngw_utils, only: tau_limb_advance - - use cires_ugwp_solv2_v1_mod, only: cires_ugwp_solv2_v1 - implicit none private @@ -78,7 +64,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & con_pi, con_rerth, pa_rf_in, tau_rf_in, con_p0, do_ugwp, & do_ugwp_v0, do_ugwp_v0_orog_only, do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - do_ugwp_v1, do_ugwp_v1_orog_only, errmsg, errflg) + errmsg, errflg) !---- initialization of unified_ugwp implicit none @@ -101,8 +87,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent (in) :: fn_nml2 !character(len=*), parameter :: fn_nml='input.nml' @@ -122,29 +107,12 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & ! Test to make sure that at most only one large-scale/blocking ! orographic drag scheme is chosen - if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl.or. & - do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & - (do_ugwp_v0_orog_only.and.(do_gsl_drag_ls_bl.or.do_ugwp_v1.or. & - do_ugwp_v1_orog_only)) .or. & - (do_gsl_drag_ls_bl.and.(do_ugwp_v1.or.do_ugwp_v1_orog_only)) .or. & - (do_ugwp_v1.and.do_ugwp_v1_orog_only) ) then + if ( (do_ugwp_v0.and.(do_ugwp_v0_orog_only.or.do_gsl_drag_ls_bl)) .or. & + (do_ugwp_v0_orog_only.and.do_gsl_drag_ls_bl) ) then write(errmsg,'(*(a))') "Logic error: Only one large-scale& &/blocking scheme (do_ugwp_v0,do_ugwp_v0_orog_only,& - &do_gsl_drag_ls_bl,do_ugwp_v1 or & - &do_ugwp_v1_orog_only) can be chosen" - errflg = 1 - return - - end if - - ! Test to make sure that if ugwp_v0 non-stationary-only is selected that - ! ugwp_v1 is not also selected - if ( do_ugwp_v0_nst_only .and. (do_ugwp_v1.or.do_ugwp_v1_orog_only) ) then - - write(errmsg,'(*(a))') "Logic error: do_ugwp_v0_nst_only can only be & - &selected if both do_ugwp_v1 and do_ugwp_v1_orog_only are not & - &selected" + &do_gsl_drag_ls_bl can be chosen" errflg = 1 return @@ -157,7 +125,7 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) then ! if (do_ugwp .or. cdmbgwd(3) > 0.0) then (deactivate effect of do_ugwp) if (cdmbgwd(3) > 0.0) then - call cires_ugwp_mod_init (me, master, nlunit, input_nml_file, logunit, & + call cires_ugwpv0_mod_init(me, master, nlunit, input_nml_file, logunit, & fn_nml2, lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) else @@ -169,13 +137,6 @@ subroutine unified_ugwp_init (me, master, nlunit, input_nml_file, logunit, & end if - if ( do_ugwp_v1 ) then - call cires_ugwp_init_v1 (me, master, nlunit, logunit, jdat, con_pi, & - con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & - con_p0, dtp, cdmbgwd(1:2), cgwf, pa_rf_in, & - tau_rf_in, errmsg, errflg) - end if - is_initialized = .true. end subroutine unified_ugwp_init @@ -192,12 +153,11 @@ end subroutine unified_ugwp_init !! subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & - do_ugwp_v1,errmsg, errflg) + errmsg, errflg) implicit none ! - logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only, & - do_ugwp_v1 + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_nst_only character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -207,9 +167,7 @@ subroutine unified_ugwp_finalize(do_ugwp_v0,do_ugwp_v0_nst_only, & if (.not.is_initialized) return - if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwp_mod_finalize() - - if ( do_ugwp_v1 ) call cires_ugwp_finalize() + if ( do_ugwp_v0 .or. do_ugwp_v0_nst_only ) call cires_ugwpv0_mod_finalize() is_initialized = .false. @@ -251,7 +209,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - do_ugwp_v1, do_ugwp_v1_orog_only, gwd_opt, errmsg, errflg) + gwd_opt, errmsg, errflg) implicit none @@ -266,7 +224,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), intent(in), dimension(im,4) :: oa4ss,ol4ss logical, intent(in) :: flag_for_gwd_generic_tend - ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + + ! elvmax is intent(in) for CIRES UGWPv1, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area @@ -324,8 +284,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & - do_ugwp_v1_orog_only + do_gsl_drag_tofd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -337,8 +296,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis real(kind=kind_phys), parameter :: tamp_mpa=30.e-3 - ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) - real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. integer :: nmtvr_temp @@ -357,8 +314,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ! 1) ORO stationary GWs ! ------------------ - zlwb(:) = 0. - ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd @@ -377,37 +332,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) - - end if - - if ( do_ugwp_v1.or.do_ugwp_v1_orog_only ) then - - ! Valery's TOFD - ! topo paras - ! w/ orographic effects - if(nmtvr == 14)then - ! calculate sgh30 for TOFD - sgh30 = abs(oro - oro_uf) - ! w/o orographic effects - else - sgh30 = varss - endif - - inv_g = 1./con_g - zmeti = phii*inv_g - zmet = phil*inv_g - - call gwdps_oro_v1 (im, levs, lonr, do_tofd, & - Pdvdt, Pdudt, Pdtdt, Pkdis, & - ugrs , vgrs, tgrs, q1, KPBL, prsi,del,prsl, & - prslk, zmeti, zmet, dtp, kdt, hprime, oc, oa4, & - clx, theta, sigma, gamma, elvmax, & - con_g, con_omega, con_rd, con_cp, con_rv,con_pi, & - con_rerth, con_fvirt, sgh30, DUSFCg, DVSFCg, & - xlat_d, sinlat, coslat, area,cdmbgwd(1:2), me, & - master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, & - tau_tofd, du3dt_mtb, du3dt_ogw, du3dt_tms) - +! +! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls +! + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + end if if ( do_ugwp_v0.or.do_ugwp_v0_orog_only.or.do_ugwp_v0_nst_only ) then @@ -445,7 +375,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (errflg/=0) return endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 end if @@ -477,7 +407,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (cdmbgwd(3) > 0.0) then ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing - call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + call slat_geos5_tamp_v0(im, tamp_mpa, xlat_d, tau_ngw) if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then if (cdmbgwd(4) > 0.0) then @@ -520,10 +450,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do k=1,levs do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + gw_dtdt(i,k) = gw_dtdt(i,k)+ Pdtdt(i,k) + gw_dudt(i,k) = gw_dudt(i,k)+ Pdudt(i,k) + gw_dvdt(i,k) = gw_dvdt(i,k)+ Pdvdt(i,k) + gw_kdis(i,k) = gw_kdis(i,k)+ Pkdis(i,k) ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) @@ -543,13 +473,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, enddo endif ! cdmbgwd(3) > 0.0 - - if (pogw == 0.0) then - tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. - dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. - endif - - + if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index f60bdc038..181ffad92 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1,13 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - dependencies = machine.F,cires_ugwp_module.F90,ugwp_driver_v0.F,cires_ugwp_triggers.F90 - dependencies = cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90 - dependencies = cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90 - dependencies = cires_vert_wmsdis.F90,cires_ugwp_module_v1.F90,cires_ugwp_triggers_v1.F90 - dependencies = cires_ugwp_initialize_v1.F90,cires_ugwp_solv2_v1_mod.F90 - dependencies = cires_ugwp_orolm97_v1.F90,cires_orowam2017.F90,cires_vert_orodis_v1.F90 - dependencies = gwdps.f,drag_suite.F90 + + dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + dependencies=drag_suite.F90 ######################################################################## [ccpp-arg-table] @@ -239,22 +236,6 @@ type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only - long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -293,14 +274,6 @@ type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1341,22 +1314,6 @@ type = logical intent = in optional = F -[do_ugwp_v1] - standard_name = do_ugwp_v1 - long_name = flag to activate ver 1 CIRES UGWP - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only - long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only - units = flag - dimensions = () - type = logical - intent = in - optional = F [gwd_opt] standard_name = gwd_opt long_name = flag to choose gwd scheme From a0efcb4e6124c5a2525b7158a144e13b24aed1b3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 1 Feb 2021 11:31:43 -0700 Subject: [PATCH 55/67] Update GFS_debug.F90 with new variables --- physics/GFS_debug.F90 | 86 ++++++++++++++++++++++++++++++++-------- physics/unified_ugwp.F90 | 4 +- 2 files changed, 72 insertions(+), 18 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2db523355..19bb2903c 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -824,8 +824,12 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_h', Grid%jindx1_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_h', Grid%jindx2_h) endif - ! Model/Control - ! not yet + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j1tau ', Grid%ddy_j1tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_j2tau ', Grid%ddy_j2tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_tau', Grid%jindx1_tau ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_tau', Grid%jindx2_tau ) + endif end if #ifdef OPENMP !$OMP BARRIER @@ -1229,21 +1233,71 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) + if (Model%do_ugwp_v1) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ngw ', Interstitial%dudt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ngw ', Interstitial%dvdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_ngw ', Interstitial%dtdt_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_ngw ', Interstitial%kdis_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ofd ', Interstitial%dvdt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zobl ', Interstitial%zobl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + end if ! CIRES UGWP v0 - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + end if !-- GSD drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index b6bd83d2c..0454ed376 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -334,7 +334,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, errmsg,errflg) ! ! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls -! +! tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. @@ -375,7 +375,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, if (errflg/=0) return endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 if (ldiag_ugwp) then du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 end if From f4c0b0bad8607ff4d9d5106bcad46253caf5944b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 1 Feb 2021 11:32:15 -0700 Subject: [PATCH 56/67] Replace tabs with whitespaces in physics/cires_ugwpv1_solv2.F90, trim trailing whitespaces --- physics/cires_ugwpv1_solv2.F90 | 1138 ++++++++++++++++---------------- 1 file changed, 569 insertions(+), 569 deletions(-) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index 07330cf8b..f282635e6 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -5,7 +5,7 @@ module cires_ugwpv1_solv2 !--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 ! dissipative solver with NonHyd/ROT-effects ! reflected GWs treated as waves with "negligible" flux, ! they are out of given column @@ -14,7 +14,7 @@ module cires_ugwpv1_solv2 subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) + pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- ! nov 2015 alternative gw-solver for nggps-wam @@ -23,17 +23,17 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! source function and *F90 CIRES-style of the code ! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out ! -------------------------------------------------------------------------------- -! - use machine, only : kind_phys +! + use machine, only : kind_phys use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt - + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch - + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max - + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & omega2, rcpd, rcpd2, pi, pi2, fv, & rad_to_deg, deg_to_rad, & @@ -41,39 +41,39 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & bnv2min, bnv2max, dw2min, velmin, gr2, & hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min ! - use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & gw_eff, & nslope, ilaunch, zms, & zci, zdci, zci4, zci3, zci2, & zaz_fct, zcosang, zsinang, nwav, nazd, & zcimin, zcimax, rimin, sc2, sc2u, ric -! +! implicit none ! real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top - real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 integer, parameter :: ener_norm =0 - integer, parameter :: ener_lsat=0 - integer, parameter :: nstdif = 1 - integer, parameter :: wave_sponge = 1 - + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + integer, intent(in) :: levs ! vertical level integer, intent(in) :: im ! horiz tiles integer, intent(in) :: mpi_id, master, kdt - - real(kind=kind_phys) ,intent(in) :: dtp ! model time step - real(kind=kind_phys) ,intent(in) :: tau_ngw(im) - - real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity - real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure - real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees real(kind=kind_phys) ,intent(in) :: sinlat(im) real(kind=kind_phys) ,intent(in) :: coslat(im) @@ -84,70 +84,70 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion - real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height ! -! -! -! local =========================================================================================== - +! +! +! local =========================================================================================== + real(kind=kind_phys) :: tauabs(im,levs) ! - real(kind=kind_phys) :: wrms(im,levs) ! - real(kind=kind_phys) :: trms(im,levs) ! - + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) ! -! local =========================================================================================== +! local =========================================================================================== real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind - - real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent - real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) -! - real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency - real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency - real(kind=kind_phys) :: rhoint(levs+1) ! interface density + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind real(kind=kind_phys) :: vint(levs+1) ! meridional wind real(kind=kind_phys) :: tint(levs+1) ! temp-re - - real(kind=kind_phys) :: irhodz_mid(levs) - real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation - real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) real(kind=kind_phys) :: v_zmet(levs+1) - real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: vueff(levs+1) real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax - + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti - real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: wrk3 real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew - real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif real(kind=kind_phys), dimension(levs) :: Qmid, AKT - real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint - real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen - + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + integer, dimension(levs) :: Anstab - - real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) - real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) real(kind=kind_phys) :: rdci(nwav), rci(nwav) real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level ! ! scalars -! - real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real(kind=kind_phys) :: c2f2, cf1, wave_distot - +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + real(kind=kind_phys) :: flux_norm ! norm-factor real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff ! - real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 real(kind=kind_phys) :: ucrit_max @@ -155,318 +155,318 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 -! +! real(kind=kind_phys) :: zdelp, zdelm, taud_min real(kind=kind_phys) :: tvc, tvm, ptc, ptm - real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 real(kind=kind_phys) :: fmode, expdis, fdis real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit real(kind=kind_phys) :: v_wdi, v_wdpc - real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam - + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop + integer :: ksrc, km2, km1, kp1, ktop ! ! Kturb-part -! - real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur - +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + real(kind=kind_phys) :: kamp, zmetk, zgrow real(kind=kind_phys) :: stab, stab_dt, dtstab - real(kind=kind_phys) :: nslope3 -! - integer :: nstab, ist + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist real(kind=kind_phys) :: w1, w2, w3, dtdif - - real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp real(kind=kind_phys) :: rstar, rstar2 real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: taub_ch, sigu2_ch real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr - + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + !-------------------------------------------------------------------------- -! +! nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw ! -! test for input fields +! test for input fields ! if (mpi_id == master .and. kdt < -2) then ! print *, im, levs, dtp, kdt, ' vay-solv2-v1' ! print *, minval(tm), maxval(tm), ' min-max-tm ' -! print *, minval(vm), maxval(vm), ' min-max-vm ' -! print *, minval(um), maxval(um), ' min-max-um ' -! print *, minval(qm), maxval(qm), ' min-max-qm ' -! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' -! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' -! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' -! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' -! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' -! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' -! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! -! endif - +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif + if (idebug_gwrms == 1) then - tauabs=0.0; wrms =0.0 ; trms =0.0 - endif - + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + rci(:) = 1./zci(:) rdci(:) = 1./zdci(:) - + rdtp = 1./dtp - rdtp2 = 0.5*rdtp - + rdtp2 = 0.5*rdtp + ksrc= max(ilaunch, 3) - km2 = ksrc - 2 + km2 = ksrc - 2 km1 = ksrc - 1 kp1 = ksrc + 1 ktop= levs+1 - + suprf(ktop) = kion(levs) - + do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 pdvdt(:,k) = 0.0 pdudt(:,k) = 0.0 pdtdt(:,k) = 0.0 dked(: ,k) = 0.0 enddo - -!----------------------------------------------------------- + +!----------------------------------------------------------- ! column-based j=1,im pjysics with 1D-arrays !----------------------------------------------------------- - DO j=1, im + DO j=1, im jl =j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max ! ! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) +! + aprsl(1:levs) = prsl(jl,1:levs) ! ! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" ! - do k=1, levs + do k=1, levs if (aprsl(k) .lt. psrc ) exit enddo - ilaunch = max(k-1, 3) + ilaunch = max(k-1, 3) ksrc= max(ilaunch, 3) - - zngw(j) = zmet(j, ksrc) - - km2 = ksrc - 2 + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 km1 = ksrc - 1 kp1 = ksrc + 1 -!=====ksrc +!=====ksrc - aum(km2:levs) = um(jl,km2:levs) - avm(km2:levs) = vm(jl,km2:levs) - atm(km2:levs) = tm(jl,km2:levs) - aqm(km2:levs) = qm(jl,km2:levs) - azmet(km2:levs) = zmet(jl,km2:levs) - aprsi(km2:levs+1) = prsi(jl,km2:levs+1) - azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) + aum(km2:levs) = um(jl,km2:levs) + avm(km2:levs) = vm(jl,km2:levs) + atm(km2:levs) = tm(jl,km2:levs) + aqm(km2:levs) = qm(jl,km2:levs) + azmet(km2:levs) = zmet(jl,km2:levs) + aprsi(km2:levs+1) = prsi(jl,km2:levs+1) + azmeti(km2:levs+1) = zmeti(jl,km2:levs+1) - - rho_src = aprsl(ksrc)*rdi/atm(ksrc) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch + taub_src = taub_ch + - - sigu2 = taub_src/rho_src/v_kxw * zms - sig_u2az(1:nazd) = sigu2 + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 ! ! compute diffusion-based arrays km2:levs -! +! do jk = km2, levs dz_meti(jk) = azmeti(jk+1)-azmeti(jk) - dz_met(jk) = azmet(jk)-azmeti(jk-1) - enddo -! --------------------------------------------- + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- ! interface mean flow parameters launch -> levs+1 ! --------------------------------------------- do jk= km1,levs tvc = atm(jk)*(1. +fv*aqm(jk)) tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) - ptc = tvc/ prslk(jl, jk) - ptm = tvm/prslk(jl,jk-1) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) ! zthm = 2.0/(tvc+tvm) - rhp_wam = zthm*gor -!interface + rhp_wam = zthm*gor +!interface uint(jk) = 0.5*(aum(jk-1)+aum(jk)) vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) + tint(jk) = 0.5*(tvc+tvm) rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters -! +! ! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) -! +! bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) - - - wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src -! + bn(jk) = sqrt(bn2(jk)) + + + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src +! ! ! diagnostics -Kzz above PBL ! uz = aum(jk) - aum(jk-1) vz = avm(jk) - avm(jk-1) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 + ritur = bn2(jk)/shr2 kamp = sqrt(shr2)*sc2 *zgrow w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp vueff(jk) = ktur + kvg(jk) - - akt(jk) = gipr/tvc + + akt(jk) = gipr/tvc enddo - if (idebug_gwrms == 1) then + if (idebug_gwrms == 1) then do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) enddo - endif + endif ! ! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! +! jk = levs - + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) uint(ktop) = aum(jk) vint(ktop) = avm(jk) - + v_zmet(ktop) = v_zmet(jk) vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) -! -! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity -! + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo - - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi ! ! project winds at ksrc -! +! do iaz=1, nazd ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) enddo ! - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) - - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 - + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + do iaz=1, nazd zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) ui(iaz, jk) = zu !- ul(iaz)*0. enddo enddo - - rstar = 1./cstar(ksrc) - rstar2 = rstar*rstar -! ----------------------------------------- + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- ! set launch momentum flux spectral density -! ----------------------------------------- +! ----------------------------------------- fpu(1:nazd, km2:ktop) =0. - + do inc=1,nwav - + zcin = zci(inc)*rstar - -! + +! ! integrate (flux(cin) x dcin ) old tau-flux and normalization ! flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) -! +! ! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] -! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo - + enddo + enddo -! +! ! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo -! + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! do inc=1, nwav flux(inc,1) = flux_norm*flux(inc,1) - enddo - - + enddo + + if (ener_norm == 1) then - snorm_ener = 0. + snorm_ener = 0. do inc=1,nwav - zcin = zci(inc)*rstar - - ze2 = zcin /(1.+ zcin**nslope3) - - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin enddo - - ekin_norm = 1./snorm_ener - + + ekin_norm = 1./snorm_ener + ! taub_src = sigu2 * rho_src * [v_kxw / zms ] -! sigu2 = taub_src*zms/(rho_src/v_kxw) -! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - - ze1 = taub_src*zms/bvi * ekin_norm - taub_src = 0. - +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 do jk=ksrc, ktop fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat enddo - - endif + + endif ! - do iaz=1,nazd + do iaz=1,nazd fpu(iaz, ksrc) = taub_src fpu(iaz, km1) = taub_src enddo - + ! copy flux-1 into other azimuths ! -------------------------------- @@ -476,146 +476,146 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & flux(inc,iaz) = flux(inc,1) enddo enddo - + ! if (mpi_id == master .and. ener_norm == 1) then ! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * ! endif - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms endif - + ! -------------------------------- - wave_act(:,:) = 1.0 + wave_act(:,:) = 1.0 ! vertical do-loop do jk=ksrc, levs - jkp = jk+1 + jkp = jk+1 ! azimuth do-loop - do iaz=1, nazd - - sig_u2az_m(iaz) = sig_u2az(iaz) - - umfp = ui(iaz, jkp) + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) umfm = ui(iaz, jk) umfc = .5*(umfm + umfp) ! wave-cin loop dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) =0.0 + sig_u2az(iaz) =0.0 ! -! wave_dis(iaz, :) = vueff(jk) +! wave_dis(iaz, :) = vueff(jk) do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) + flux_m(inc, iaz) = flux(inc, iaz) zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if(wave_act(inc,iaz) == 1.0) then + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then !======================================================================= ! discrete mode ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -!======================================================================= - +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then ! ! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption ! - wave_act(inc,iaz) =0. + wave_act(inc,iaz) =0. akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - - else - + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + v_wdp = v_kxw*v_cdp wdop2 = v_wdp* v_wdp - -! + +! ! rotational cut-off -! +! kzw2 = (bn2(jkp)-wdop2)/Cdf2 ! -!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 -! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! if ( kzw2 > mkz2min ) then v_kzw = sqrt(kzw2) akzw(inc, iaz, jkp) = v_kzw -! +! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) ! Kds_sat = kxw*Cdf1*rhp2/kzw3 !krad, kvg, kion, ktg v_cdp = sqrt( cdf2 ) v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc - -! - ze1 = v_kzi*v_zmet(jk) - - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1./(1.+ ze1) - endif - -! - wave_act(inc,iaz) = 1.0 + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc + +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 fmode = flux(inc,iaz) - - flux_2_sig = v_kzw/v_kxw/rhoint(jkp) - w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) else ! kzw2 <= mkz2min large "Lz"-reflection - + expdis = 1.0 v_kzw = mkzmin - + v_cdp = 0. ! no effects of reflected waves wave_act(inc,iaz) = 0.0 akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - w1 =0. + fmode = 0. + w1 =0. endif ! expdis =1.0 - + fdis = fmode*expdis*wave_act(inc,iaz) !============================================================================== ! ! Saturated Fluxes and Energy: Spectral and Dicrete Modes -! +! ! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin ! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) ! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 ! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] ! ! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) ! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! +! ! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! +! ! ! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) ! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 @@ -623,402 +623,402 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] -! +! ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc -! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - - if (ener_norm == 1) then - -! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) - -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) -! - endif +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif !---------------------------------------------------------------------------- -! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw ! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat ! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat !---------------------------------------------------------------------------- zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa if(zdep > 0.0 ) then ! subs on sat-limit - ze1 = flux(inc,iaz) + ze1 = flux(inc,iaz) flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer else ! assign dis-ve flux flux(inc,iaz) = fdis endif - - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif ! ! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" ! if ( azmeti(jkp) .ge. zsp_gw) then - mi_sponge = .5/dz_meti(jk) - ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] - v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc -! - ze1 = v_kzi*v_zmet(jk) - exp_sponge = exp(-ze1) -! + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + exp_sponge = exp(-ze1) +! ! additional sponge -! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then endif ! only for waves w/o CL-absorption wave_act=1 ! ! sum for given (jk, iaz) all active "wave" contributions -! - if (wave_act(inc,iaz) == 1) then - - zcinc =zdci(inc) +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) vc_zflx_mode = flux(inc,iaz) vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz - + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! (heat deposition integration over spectral mode for each azimuth ! later sum over selected azimuths as "non-negative" scalars) ! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc - +! zdelp = wrk3(jk)*cdf1 *zcinc + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff - -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp ! cool = -Kt*N2/R -! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] -! +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) -! - enddo ! wave-inc-loop - + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + ze1 =fpu(iaz, jk) if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 ! ! compute wind and temp-re rms ! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif ! -------------- enddo ! end Azimuth do-loop - -! -! eddy wave dissipation to limit GW-rms -! - tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) - ze1=max(dked_min, tx1) - ze2=min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) -! + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) + ze1=max(dked_min, tx1) + ze2=min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) +! enddo ! end Vertical do-loop ! ! top-layers constant interface-fluxes and zero-heat -! we allow non-zero momentum fluxes and thermal effects -! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) ! dfdz_v(1:nazd, levs) = 0.0 - -! --------------------------------------------------------------------- + +! --------------------------------------------------------------------- ! sum contribution for total zonal and meridional fluxes + ! energy dissipation ! --------------------------------------------------- -! +! !======================================================================== ! at the source level and below taux = 0 (taux_E=-taux_W by assumption) !======================================================================== - + do jk=ksrc, levs - taux(jk) = 0.0 - tauy(jk) = 0.0 + taux(jk) = 0.0 + tauy(jk) = 0.0 do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) - enddo + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo enddo jk = ktop; taux(jk)=0.; tauy(jk)=0. - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) enddo - - if (idebug_gwrms == 1) then - do jk=kp1, levs - do iaz=1,nazd + + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) enddo - enddo - endif + enddo + endif ! do jk=ksrc+1,levs jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp ze2 = (tauy(jkp)-tauy(jk))* zdelp - + if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) - endif + endif if (abs(ze2) >= maxdudt ) then ze2 = sign(maxdudt, ze2) endif - + pdudt(jl,jk) = -ze1 pdvdt(jl,jk) = -ze2 ! ! Cx =0 based Cx=/= 0. above ! -! +! if (knob_ugwp_doheat == 1) then -! +! !maxdtdt= dked_max * bnfix2 -! +! pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - - dked(jl,jk) = dked(jl,jk)/bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif enddo -!---------------------------------------------------------------------------------- +!---------------------------------------------------------------------------------- ! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur ! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt ! can check "stability" in the column and "add" ktur-estimation ! to suppress instability as needed so dked = dked_gw + ktur_ric -!---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) ! - do ist= 1, nstdif + do ist= 1, nstdif do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) enddo dktur(ksrc:levs-1) = adif(ksrc:levs-1) enddo dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) dktur(levs+1) = dktur(levs) - + do jk=ksrc,levs - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo - + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + ! ! Thermal budget qmid = qheat + qcool -! - do jk=ksrc+1,levs +! + do jk=ksrc+1,levs ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) - enddo + dked(jl, jk) = dktur(jk) + enddo ! ! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" ! from the surface/launch-gw to the "top" -! +! ! ! update by source function X(t+dt) = X(t) + dtp * dXdt -! - uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp - vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp - told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp ! ! diagnose turb-profile using "stability-check" relying on the free-atm diffusion ! sc2 = 30m x 30m -! - dktur(km2:levs) = dked_min - - do jk=km1,levs - uz = uold(jk) - uold(jk-1) +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1./ze1 - + ze1 = dz_met(jk) + zdelm = 1./ze1 + tvc = told(jk) * (1. +fv*aqm(jk)) tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1./(1. + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) ! ! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const -! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur= min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur ! ! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur - - enddo - +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + ! ! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability -! - if (knob_ugwp_dokdis == 2) then - +! + if (knob_ugwp_dokdis == 2) then + do jk=km1,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - - kvint(ktop) = kvint(levs) - - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. - do jk=km1,levs-1 - - dzmetp = 1./dz_met(jk+1) - dzmetf = 1./(dz_meti(jk)*rhomid(jk)) - - - ktur = kvint(jk) *rhoint(jk) * dzmetf - kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk)+cdif(jk) - ACdif(jk) = ApC - - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - -! if (nstab .ge. 3) print *, 'nstab ', nstab -! + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! ! k instead Jk -! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif - - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo - - uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du - vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif - told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif ! ! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs ! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) enddo ! ! compute "smoothed" tendencies by molecular + GW-eddy diffusions -! - do k=ksrc,levs-1 -! +! + do k=ksrc,levs-1 +! ! final updates of tendencies and diffusion -! - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) - - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) - endif + endif if (abs(ze2) >= maxdudt ) then ze2 = sign(maxdudt, ze2) endif - - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) vz = vold(k+1) - vold(k-1) - ze2 = 1./(dz_met(k+1)+dz_met(k) ) - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity - - enddo - - - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + enddo ! J-loop -! - RETURN - -!================================= diag print after "return" ====================== +! + RETURN + +!================================= diag print after "return" ====================== if (kdt ==1 .and. mpi_id == master) then -! +! print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) ! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min print * - + endif - + if (kdt == 1 .and. mpi_id == master) then print *, 'vgw done nstab ', nstab ! @@ -1029,8 +1029,8 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! ! print *, ' ugwp -heating rates ' endif -!================================= - return +!================================= + return end subroutine cires_ugwpv1_ngw_solv2 From 28a7793c5408bf2a8797f5809f2d34606207d035 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 3 Feb 2021 08:51:39 -0700 Subject: [PATCH 57/67] Fix uninitialized variables in physics/cires_ugwpv1_solv2.F90 --- physics/cires_ugwpv1_solv2.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index f282635e6..ee8f7bc83 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -840,7 +840,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) dktur(levs+1) = dktur(levs) - do jk=ksrc,levs + do jk=ksrc,levs+1 ze1 = .5*( dktur(jk) +dktur(jk-1) ) kvint(jk) = ze1 ktint(jk) = ze1*iPr_ktgw @@ -909,14 +909,14 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! if (knob_ugwp_dokdis == 2) then - do jk=km1,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) - kvint(ktop) = kvint(levs) - dzmetm = 1./dz_met(km1) Adif(km1:levs) = 0. Cdif(km1:levs) = 0. From 7cf1a0aa9d980316964eab2ea57f5887f7a09446 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 4 Feb 2021 10:37:34 -0700 Subject: [PATCH 58/67] Add calls to initialize LSM lookup tables to GFS_phys_time_vary.fv3.{F90,meta} --- physics/GFS_phys_time_vary.fv3.F90 | 86 ++++++++++++++--------- physics/GFS_phys_time_vary.fv3.meta | 105 +++++++++++++++++++++++++++- 2 files changed, 157 insertions(+), 34 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 8f0bc50d9..84c284540 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -29,10 +29,9 @@ module GFS_phys_time_vary use gcycle_mod, only : gcycle -#if 0 !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx -#endif + use set_soilveg_mod, only: set_soilveg implicit none @@ -42,9 +41,12 @@ module GFS_phys_time_vary logical :: is_initialized = .false. - real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys - real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys - real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys + real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys + real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys + real(kind=kind_phys), parameter :: drythresh = 1.e-4_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys contains @@ -58,7 +60,8 @@ subroutine GFS_phys_time_vary_init ( jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & - nthrds, errmsg, errflg) + isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_ruc, min_seaice, fice, landfrac, & + vtype, weasd, nthrds, errmsg, errflg) implicit none @@ -78,12 +81,19 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(inout) :: ddy_ci(:), ddx_ci(:) integer, intent(inout) :: imap(:), jmap(:) + integer, intent(in) :: isot, ivegsrc, nlunit + real(kind_phys), intent(inout) :: sncovr(:), sncovr_ice(:) + integer, intent(in) :: lsm, lsm_ruc + real(kind_phys), intent(in) :: min_seaice, fice(:) + real(kind_phys), intent(in) :: landfrac(:), vtype(:), weasd(:) + integer, intent(in) :: nthrds character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables - integer :: i, j, ix + integer :: i, j, ix, vegtyp + real(kind_phys) :: rsnow ! Initialize CCPP error handling variables errmsg = '' @@ -100,7 +110,9 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & -!$OMP private (ix,i,j) +!$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & +!$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & +!$OMP private (ix,i,j,rsnow,vegtyp) !$OMP sections @@ -177,6 +189,10 @@ subroutine GFS_phys_time_vary_init ( ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif +!$OMP section +!> - Initialize soil vegetation (needed for sncovr calculation further down) + call set_soilveg(me, isot, ivegsrc, nlunit) + !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") @@ -223,35 +239,39 @@ subroutine GFS_phys_time_vary_init ( enddo enddo +!$OMP section + !--- if sncovr does not exist in the restart, need to create it + if (all(sncovr < zero)) then + if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + sncovr(:) = zero + do ix=1,im + if (landfrac(ix) >= drythresh .or. fice(ix) >= min_seaice) then + vegtyp = vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001_kind_phys*weasd(ix)/snupx(vegtyp) + if (0.001_kind_phys*weasd(ix) < snupx(vegtyp)) then + sncovr(ix) = one - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + sncovr(ix) = one + endif + endif + enddo + endif + + !--- For RUC LSM: create sncovr_ice from sncovr + if (lsm == lsm_ruc) then + if (all(sncovr_ice < zero)) then + if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' + sncovr_ice(:) = sncovr(:) + endif + endif + !$OMP end sections !$OMP end parallel -#if 0 - !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) - if (first_time_step) then - if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then - !--- compute sncovr from existing variables - !--- code taken directly from read_fix.f - do nb = 1, nblks - do ix = 1, Model%blksz(nb) - Data(nb)%Sfcprop%sncovr(ix) = 0.0 - if (Data(nb)%Sfcprop%slmsk(ix) > 0.001) then - vegtyp = Data(nb)%Sfcprop%vtype(ix) - if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*Data(nb)%Sfcprop%weasd(ix)/snupx(vegtyp) - if (0.001*Data(nb)%Sfcprop%weasd(ix) < snupx(vegtyp)) then - Data(nb)%Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) - else - Data(nb)%Sfcprop%sncovr(ix) = 1.0 - endif - endif - enddo - enddo - endif - endif -#endif - is_initialized = .true. end subroutine GFS_phys_time_vary_init diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 7ae6b4948..4a625f6c0 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F + dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F ######################################################################## [ccpp-arg-table] @@ -307,6 +307,64 @@ type = integer intent = inout optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for file opens + units = none + dimensions = () + type = integer + intent = in + optional = F +[sncovr] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr_ice] + standard_name = surface_snow_area_fraction_over_ice + long_name = surface snow area fraction over ice + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + 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 +[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 [nthrds] standard_name = omp_threads long_name = number of OpenMP threads available for physics schemes @@ -315,6 +373,51 @@ type = integer intent = in optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + 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 = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 7d45f106c3caf2898d8f37cd462aabe95dbf435b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 9 Feb 2021 14:09:42 -0700 Subject: [PATCH 59/67] Update and cleanup of UGWPv0, UGWpv1 and drag suite standard names --- physics/GFS_debug.F90 | 38 +++++++---- physics/GFS_phys_time_vary.fv3.meta | 60 ++++++++--------- physics/cires_ugwp.meta | 12 ++-- physics/cires_ugwp_post.meta | 10 +-- physics/drag_suite.meta | 54 ++++++++-------- physics/ugwpv1_gsldrag.F90 | 8 +-- physics/ugwpv1_gsldrag.meta | 93 ++++++++++++--------------- physics/ugwpv1_gsldrag_post.meta | 18 +++--- physics/unified_ugwp.F90 | 20 +++--- physics/unified_ugwp.meta | 99 +++++++++++++---------------- physics/unified_ugwp_post.meta | 10 +-- 11 files changed, 208 insertions(+), 214 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 19bb2903c..8f072cae6 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1262,31 +1262,24 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zobl ', Interstitial%zobl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if ! CIRES UGWP v0 if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) @@ -1299,12 +1292,31 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if !-- GSD drag suite - if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then + if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & + Model%gwd_opt==2 .or. Model%gwd_opt==22) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ocss ', Interstitial%ocss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if + if (Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) + end if ! GFDL and Thompson MP if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index e20920686..887037924 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -316,7 +316,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -324,39 +324,39 @@ intent = in optional = F [jindx1_tau] - standard_name = index_interp_weight1_taungw - long_name = index1 for weight1 for tau NGWs + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = inout - optional = F + optional = F [jindx2_tau] - standard_name = index_interp_weight2_taungw - long_name = index2 for weight2 for tau NGWs + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = inout - optional = F + optional = F [ddy_j1tau] - standard_name = interp_weight1_taungw - long_name = interpolation weight1 for tau NGWs + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real - intent = inout + intent = inout kind = kind_phys - optional = F + optional = F [ddy_j2tau] - standard_name = interp_weight2_taungw - long_name = interpolation weight2 for tau NGWs + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real intent = inout kind = kind_phys - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -492,7 +492,7 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer intent = in @@ -1378,7 +1378,7 @@ intent = inout optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -1386,33 +1386,33 @@ intent = in optional = F [jindx1_tau] - standard_name = index_interp_weight1_taungw - long_name = index1 for weight1 for tau NGWs + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = in - optional = F + optional = F [jindx2_tau] - standard_name = index_interp_weight2_taungw - long_name = index2 for weight2 for tau NGWs + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = integer intent = in - optional = F + optional = F [ddy_j1tau] - standard_name = interp_weight1_taungw - long_name = interpolation weight1 for tau NGWs + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real - intent = in + intent = in kind = kind_phys - optional = F + optional = F [ddy_j2tau] - standard_name = interp_weight2_taungw - long_name = interpolation weight2 for tau NGWs + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs units = none dimensions = (horizontal_loop_extent) type = real @@ -1420,14 +1420,14 @@ kind = kind_phys optional = F [tau_amf] - standard_name = ngw_abs_momentum_flux + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag long_name = ngw_absolute_momentum_flux units = various dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout - optional = F + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index 887280612..e2afbf70f 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -565,7 +565,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -574,7 +574,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -583,7 +583,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -592,7 +592,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -673,7 +673,7 @@ intent = out optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -682,7 +682,7 @@ intent = out optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 80b8ce1ca..c8618e1c8 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index fa5b317fc..3035a2c95 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -274,7 +274,7 @@ intent = inout optional = F [dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -283,7 +283,7 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y momentum tendency from large scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -292,7 +292,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -301,7 +301,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -310,7 +310,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -319,7 +319,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -328,7 +328,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -337,7 +337,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -364,72 +364,72 @@ intent = out optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -592,7 +592,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -600,7 +600,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -608,7 +608,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 4439845ad..28a4110fc 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -312,7 +312,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, area, & rain, br1, hpbl, kpbl, slmsk, & ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, del, tau_amf, & - dudt_ogw, dvdt_ogw, dtdt_sso, du_ogwcol, dv_ogwcol, & + dudt_ogw, dvdt_ogw, du_ogwcol, dv_ogwcol, & dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & dudt_oss, dvdt_oss, du_osscol, dv_osscol, & dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & @@ -408,7 +408,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_osscol, dv_osscol, du_ofdcol, dv_ofdcol ! -! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) +! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) ! du_ngwcol, dv_ngwcol real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg @@ -419,9 +419,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_sso, dtdt_ngw, dtdt_gw + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw ! diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 1cfec2104..2eac9a321 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -207,7 +207,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -215,7 +215,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -223,7 +223,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -231,7 +231,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -239,7 +239,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -247,7 +247,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -255,7 +255,7 @@ intent = in optional = F [do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only + standard_name = flag_for_ugwp_version_1_orographic_gwd long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -263,7 +263,7 @@ intent = in optional = F [do_ugwp_v1_w_gsldrag] - standard_name = do_ugwp_v1_w_gsldrag + standard_name = flag_for_ugwp_version_1_nonorographic_gwd long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL units = flag dimensions = () @@ -413,7 +413,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -421,7 +421,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -429,7 +429,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -437,7 +437,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -445,7 +445,7 @@ intent = in optional = F [do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only + standard_name = flag_for_ugwp_version_1_orographic_gwd long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -453,7 +453,7 @@ intent = in optional = F [do_ugwp_v1_w_gsldrag] - standard_name = do_ugwp_v1_w_gsldrag + standard_name = flag_for_ugwp_version_1_nonorographic_gwd long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL units = flag dimensions = () @@ -806,7 +806,7 @@ intent = in optional = F [tau_amf] - standard_name = ngw_abs_momentum_flux + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag long_name = ngw_absolute_momentum_flux units = various dimensions = (horizontal_loop_extent) @@ -815,7 +815,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -824,7 +824,7 @@ intent = out optional = F [dvdt_ogw] - standard_name = y_momentum_tendency_from_meso_scale_ogw + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -832,17 +832,8 @@ kind = kind_phys intent = out optional = F -[dtdt_sso] - standard_name = tendency_of_air_temperature_due_to_sso - long_name = air temperature tendency due to subgrid-scale orography - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [du_ogwcol] - standard_name = integrated_x_momentum_flux_from_meso_scale_ogw + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from meso scale ogw units = Pa dimensions = (horizontal_loop_extent) @@ -851,7 +842,7 @@ intent = out optional = F [dv_ogwcol] - standard_name = integrated_y_momentum_flux_from_meso_scale_ogw + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from meso scale ogw units = Pa dimensions = (horizontal_loop_extent) @@ -860,7 +851,7 @@ intent = out optional = F [dudt_obl] - standard_name = x_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -869,7 +860,7 @@ intent = out optional = F [dvdt_obl] - standard_name = y_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -878,7 +869,7 @@ intent = out optional = F [du_oblcol] - standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -887,7 +878,7 @@ intent = out optional = F [dv_oblcol] - standard_name = integrated_y_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -896,7 +887,7 @@ intent = out optional = F [dudt_oss] - standard_name = x_momentum_tendency_from_small_scale_gwd_vy + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -905,7 +896,7 @@ intent = out optional = F [dvdt_oss] - standard_name = y_momentum_tendency_from_small_scale_gwd_vy + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -914,7 +905,7 @@ intent = out optional = F [du_osscol] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd units = Pa dimensions = (horizontal_loop_extent) @@ -923,7 +914,7 @@ intent = out optional = F [dv_osscol] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd units = Pa dimensions = (horizontal_loop_extent) @@ -932,7 +923,7 @@ intent = out optional = F [dudt_ofd] - standard_name = x_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -941,7 +932,7 @@ intent = out optional = F [dvdt_ofd] - standard_name = y_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -950,7 +941,7 @@ intent = out optional = F [du_ofdcol] - standard_name = integrated_x_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -959,7 +950,7 @@ intent = out optional = F [dv_ofdcol] - standard_name = integrated_y_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -968,7 +959,7 @@ intent = out optional = F [dudt_ngw] - standard_name = tendency_of_x_wind_due_to_ngw + standard_name = tendency_of_x_wind_due_to_nonorographic_gravity_wave_drag long_name = zonal wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -977,7 +968,7 @@ intent = out optional = F [dvdt_ngw] - standard_name = tendency_of_y_wind_due_to_ngw + standard_name = tendency_of_y_wind_due_to_nonorographic_gravity_wave_drag long_name = meridional wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -986,7 +977,7 @@ intent = out optional = F [dtdt_ngw] - standard_name = tendency_of_air_temperature_due_to_ngw + standard_name = tendency_of_air_temperature_due_to_nonorographic_gravity_wave_drag long_name = air temperature tendency due to non-stationary GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -995,7 +986,7 @@ intent = out optional = F [kdis_ngw] - standard_name = eddy_mixing_due_to_ngw + standard_name = atmosphere_momentum_diffusivity_due_to_nonorographic_gravity_wave_drag long_name = eddy mixing due to non-stationary GWs units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1004,7 +995,7 @@ intent = out optional = F [dudt_gw] - standard_name = tendency_of_x_wind_due_to_allgw + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1013,7 +1004,7 @@ intent = out optional = F [dvdt_gw] - standard_name = tendency_of_y_wind_due_to_allgw + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1022,7 +1013,7 @@ intent = out optional = F [dtdt_gw] - standard_name = tendency_of_air_temperature_due_to_allgw + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to all GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1031,7 +1022,7 @@ intent = out optional = F [kdis_gw] - standard_name = eddy_mixing_due_to_allgw + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to all GWs units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1058,7 +1049,7 @@ intent = out optional = F [tau_oss] - standard_name = instantaneous_momentum_flux_due_to_sso + standard_name = momentum_flux_due_to_subgrid_scale_orographic_gravity_wave_drag long_name = momentum flux or stress due to SSO including OBL-OSS-OFD units = Pa dimensions = (horizontal_loop_extent) @@ -1085,7 +1076,7 @@ intent = out optional = F [zobl] - standard_name = height_of_mountain_blocking_v1 + standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag_v1 units = m dimensions = (horizontal_loop_extent) @@ -1094,7 +1085,7 @@ intent = out optional = F [zngw] - standard_name = height_of_launch_level_of_nonsta_gravity_wave + standard_name = height_of_launch_level_of_nonorographic_gravity_waves long_name = height of launch level of non-stationary GWs units = m dimensions = (horizontal_loop_extent) diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta index 9ed76d6e8..45fa4ea99 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/ugwpv1_gsldrag_post.meta @@ -46,7 +46,7 @@ intent = in optional = F [dudt_gw] - standard_name = tendency_of_x_wind_due_to_allgw + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -55,7 +55,7 @@ intent = in optional = F [dvdt_gw] - standard_name = tendency_of_y_wind_due_to_allgw + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to all GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -64,7 +64,7 @@ intent = in optional = F [dtdt_gw] - standard_name = tendency_of_air_temperature_due_to_allgw + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to all GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -73,7 +73,7 @@ intent = in optional = F [du_oblcol] - standard_name = integrated_x_momentum_flux_from_blocking_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag units = Pa dimensions = (horizontal_loop_extent) @@ -82,7 +82,7 @@ intent = in optional = F [du_ofdcol] - standard_name = integrated_x_momentum_flux_from_form_drag_vy + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag units = Pa dimensions = (horizontal_loop_extent) @@ -109,7 +109,7 @@ intent = in optional = F [zobl] - standard_name = height_of_mountain_blocking_v1 + standard_name = height_of_mountain_blocking long_name = height of mountain blocking drag_v1 units = m dimensions = (horizontal_loop_extent) @@ -135,7 +135,7 @@ intent = in optional = F [dudt_obl] - standard_name = x_momentum_tendency_from_blocking_drag_vy + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -144,7 +144,7 @@ intent = in optional = F [dudt_ofd] - standard_name = x_momentum_tendency_from_form_drag_vy + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -153,7 +153,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = x momentum tendency from meso scale ogw units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 0454ed376..7fdc43b2b 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -185,7 +185,7 @@ end subroutine unified_ugwp_finalize !>@brief These subroutines and modules execute the CIRES UGWP Version 0 !>\defgroup unified_ugwp_run Unified Gravity Wave Physics General Algorithm !> @{ -!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and background dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). +!! The physics of NGWs in the UGWP framework (Yudin et al. 2018 \cite yudin_et_al_2018) is represented by four GW-solvers, which is introduced in Lindzen (1981) \cite lindzen_1981, Hines (1997) \cite hines_1997, Alexander and Dunkerton (1999) \cite alexander_and_dunkerton_1999, and Scinocca (2003) \cite scinocca_2003. The major modification of these GW solvers is represented by the addition of the background dissipation of temperature and winds to the saturation criteria for wave breaking. This feature is important in the mesosphere and thermosphere for WAM applications and it considers appropriate scale-dependent dissipation of waves near the model top lid providing the momentum and energy conservation in the vertical column physics (Shaw and Shepherd 2009 \cite shaw_and_shepherd_2009). In the UGWP-v0, the modification of Scinocca (2003) \cite scinocca_2003 scheme for NGWs with non-hydrostatic and rotational effects for GW propagations and backgroufnd dissipation is represented by the subroutine \ref fv3_ugwp_solv2_v0. In the next release of UGWP, additional GW-solvers will be implemented along with physics-based triggering of waves and stochastic approaches for selection of GW modes characterized by horizontal phase velocities, azimuthal directions and magnitude of the vertical momentum flux (VMF). !! !! In UGWP-v0, the specification for the VMF function is adopted from the GEOS-5 global atmosphere model of GMAO NASA/GSFC, as described in Molod et al. (2015) \cite molod_et_al_2015 and employed in the MERRRA-2 reanalysis (Gelaro et al., 2017 \cite gelaro_et_al_2017). The Fortran subroutine \ref slat_geos5_tamp describes the latitudinal shape of VMF-function as displayed in Figure 3 of Molod et al. (2015) \cite molod_et_al_2015. It shows that the enhanced values of VMF in the equatorial region gives opportunity to simulate the QBO-like oscillations in the equatorial zonal winds and lead to more realistic simulations of the equatorial dynamics in GEOS-5 operational and MERRA-2 reanalysis products. For the first vertically extended version of FV3GFS in the stratosphere and mesosphere, this simplified function of VMF allows us to tune the model climate and to evaluate multi-year simulations of FV3GFS with the MERRA-2 and ERA-5 reanalysis products, along with temperature, ozone, and water vapor observations of current satellite missions. After delivery of the UGWP-code, the EMC group developed and tested approach to modulate the zonal mean NGW forcing by 3D-distributions of the total precipitation as a proxy for the excitation of NGWs by convection and the vertically-integrated (surface - tropopause) Turbulent Kinetic Energy (TKE). The verification scores with updated NGW forcing, as reported elsewhere by EMC researchers, display noticeable improvements in the forecast scores produced by FV3GFS configuration extended into the mesosphere. !! @@ -203,7 +203,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, ugrs, vgrs, tgrs, q1, prsi, prsl, prslk, phii, phil, & del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & - dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt_mtb, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & dudt, dvdt, dtdt, rdxzb, con_g, con_omega, con_pi, con_cp, con_rd, con_rv, & con_rerth, con_fvirt, rain, ntke, q_tke, dqdt_tke, lprnt, ipr, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_cgw, ldv3dt_cgw, ldt3dt_cgw, & @@ -244,7 +244,6 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & dusfc_ss(:),dvsfc_ss(:), & & dusfc_fd(:),dvsfc_fd(:) real(kind=kind_phys), intent(out) :: & - & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & & dtaux2d_fd(:,:),dtauy2d_fd(:,:) @@ -253,11 +252,12 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, & hpbl(im), & & slmsk(im) - real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg - real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb - real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw - real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis - real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb + real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(out), dimension(im, levs) :: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis + real(kind=kind_phys), intent(out), dimension(:,:) :: dudt_mtb, dudt_tms + real(kind=kind_phys), intent(out), dimension(:,:) :: dtaux2d_ls, dtauy2d_ls ! These arrays are only allocated if ldiag=.true. real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw @@ -333,10 +333,10 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) ! -! put zeros due to xy GSL-drag style: dtauy2d_ls,dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls +! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls ! tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. - dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + dudt_mtb = 0. ; dudt_tms = 0. end if diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 181ffad92..edb8521e0 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -189,7 +189,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -197,7 +197,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -205,7 +205,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -213,7 +213,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -221,7 +221,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -229,7 +229,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -259,7 +259,7 @@ name = unified_ugwp_finalize type = scheme [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -267,7 +267,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -512,80 +512,80 @@ intent = in optional = F [dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated x momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from large scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag - units = Pa s + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F [dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd - long_name = x momentum tendency from large scale gwd + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -593,8 +593,8 @@ intent = out optional = F [dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd - long_name = y momentum tendency from large scale gwd + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = instantaneous change in y wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real @@ -602,7 +602,7 @@ intent = out optional = F [dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag + standard_name = tendency_of_x_momentum_due_to_blocking_drag long_name = x momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -611,7 +611,7 @@ intent = out optional = F [dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag + standard_name = tendency_of_y_momentum_due_to_blocking_drag long_name = y momentum tendency from blocking drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -620,7 +620,7 @@ intent = out optional = F [dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag long_name = x momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -629,7 +629,7 @@ intent = out optional = F [dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -638,7 +638,7 @@ intent = out optional = F [dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag + standard_name = tendency_of_x_momentum_due_to_form_drag long_name = x momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -647,7 +647,7 @@ intent = out optional = F [dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag + standard_name = tendency_of_y_momentum_due_to_form_drag long_name = y momentum tendency from form drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -877,7 +877,7 @@ intent = out optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -886,7 +886,7 @@ intent = out optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -895,7 +895,7 @@ intent = out optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -904,7 +904,7 @@ intent = out optional = F [gw_kdis] - standard_name = eddy_mixing_due_to_ugwp + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag long_name = eddy mixing due to UGWP units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -984,17 +984,8 @@ kind = kind_phys intent = out optional = F -[dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag - long_name = instantaneous change in x wind due to orographic gw drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -1267,7 +1258,7 @@ intent = in optional = F [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -1275,7 +1266,7 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () @@ -1283,7 +1274,7 @@ intent = in optional = F [do_ugwp_v0_nst_only] - standard_name = do_ugwp_v0_nst_only + standard_name = flag_for_ugwp_version_0_nonorographic_gwd long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only units = flag dimensions = () @@ -1291,7 +1282,7 @@ intent = in optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -1299,7 +1290,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -1307,7 +1298,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index 85a6bff8e..0e30d4489 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -41,7 +41,7 @@ intent = in optional = F [gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag long_name = air temperature tendency due to UGWP units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -50,7 +50,7 @@ intent = in optional = F [gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag long_name = zonal wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -59,7 +59,7 @@ intent = in optional = F [gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag long_name = meridional wind tendency due to UGWP units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -140,7 +140,7 @@ intent = in optional = F [dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = instantaneous change in x wind due to orographic gw drag units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -149,7 +149,7 @@ intent = in optional = F [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) From 0467d63c8baf1f38ae5955e2094ca004df1bccd2 Mon Sep 17 00:00:00 2001 From: Ruiyu Sun Date: Wed, 10 Feb 2021 00:44:36 +0000 Subject: [PATCH 60/67] Fix bugs in the pre-rad to have correct radii and radiation fluxes --- physics/GFS_rrtmg_pre.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 109df3b65..c18396221 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -288,7 +288,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & plyr(i,k1) = prsl(i,k2) * 0.01 ! pa to mb (hpa) tlyr(i,k1) = tgrs(i,k2) prslk1(i,k1) = prslk(i,k2) - rho(i,k1) = plyr(i,k1)/(con_rd*tlyr(i,k1)) + rho(i,k1) = prsl(i,k2)/(con_rd*tlyr(i,k1)) orho(i,k1) = 1.0/rho(i,k1) !> - Compute relative humidity. @@ -774,7 +774,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !tgs: progclduni has different limits for ice radii (10.0-150.0) than ! calc_effectRad (4.99-125.0 for WRFv3.8.1; 2.49-125.0 for WRFv4+) ! it will raise the low limit from 5 to 10, but the high limit will remain 125. - call calc_effectRad (tlyr(i,:), plyr(i,:), qv_mp(i,:), qc_mp(i,:), & + call calc_effectRad (tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & re_cloud(i,:), re_ice(i,:), re_snow(i,:), 1, lm ) end do From e354d11f5ff991c60ddadcef5df94e65c2f5c08f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 10 Feb 2021 16:14:02 -0700 Subject: [PATCH 61/67] Update physics/GFS_debug.F90 with additional UGWP changes --- physics/GFS_debug.F90 | 106 ++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 70 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 8f072cae6..cbc65fa79 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -675,6 +675,28 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if + ! UGWP - incomplete list + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%%dudt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%%dvdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%%dtdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%%kdis_gw) + if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_obl ', Diag%dvdt_obl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_oss ', Diag%dudt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_oss ', Diag%dvdt_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ofd ', Diag%dudt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ofd ', Diag%dvdt_ofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ogwcol ', Diag%du_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ogwcol ', Diag%dv_ogwcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_oblcol ', Diag%du_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_oblcol ', Diag%dv_oblcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_osscol ', Diag%du_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_osscol ', Diag%dv_osscol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) + end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsi' , Statein%prsi) @@ -1233,63 +1255,25 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) + ! UGWP + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) + ! UGWP v1 if (Model%do_ugwp_v1) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ngw ', Interstitial%dudt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ngw ', Interstitial%dvdt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_ngw ', Interstitial%dtdt_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_ngw ', Interstitial%kdis_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ofd ', Interstitial%dvdt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zngw ', Interstitial%zngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) - end if - ! CIRES UGWP v0 - if (Model%do_ugwp_v0 .or. Model%do_gsl_drag_ls_bl .or. Model%do_gsl_drag_ss .or. Model%do_gsl_drag_tofd) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_gw ', Interstitial%dudt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_gw ', Interstitial%dvdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt_gw ', Interstitial%dtdt_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kdis_gw ', Interstitial%kdis_gw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) end if !-- GSD drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & @@ -1299,24 +1283,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if - if (Model%gwd_opt==33 .or. Model%gwd_opt==22) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ogwcol ', Interstitial%du_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ogwcol ', Interstitial%dv_ogwcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_obl ', Interstitial%dudt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_obl ', Interstitial%dvdt_obl ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_oblcol ', Interstitial%du_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_oblcol ', Interstitial%dv_oblcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_oss ', Interstitial%dudt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_oss ', Interstitial%dvdt_oss ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_osscol ', Interstitial%du_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_osscol ', Interstitial%dv_osscol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ofd ', Interstitial%dudt_ofd ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt_ogw ', Interstitial%dvdt_ogw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%du_ofdcol ', Interstitial%du_ofdcol ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dv_ofdcol ', Interstitial%dv_ofdcol ) - end if ! GFDL and Thompson MP if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) From 828759a2333074787b0d65f2eef93915a2b086f2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 11 Feb 2021 15:14:57 -0700 Subject: [PATCH 62/67] Update physics/GFS_debug.F90, and fix formatting in physics/ugwpv1_gsldrag.F90 --- physics/GFS_debug.F90 | 10 +- physics/ugwpv1_gsldrag.F90 | 382 ++++++++++++++++++------------------- 2 files changed, 197 insertions(+), 195 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index cbc65fa79..5ecc9d8a3 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -676,10 +676,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if ! UGWP - incomplete list - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%%dudt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%%dvdt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%%dtdt_gw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%%kdis_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_gw ', Diag%dudt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_gw ', Diag%dvdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%dtdt_gw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%kdis_gw) if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) @@ -696,6 +696,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_osscol ', Diag%dv_osscol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) + else + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw) end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 28a4110fc..24ab2b2d1 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -37,12 +37,12 @@ module ugwpv1_gsldrag use machine, only: kind_phys - + use cires_ugwpv1_triggers, only: slat_geos5_2020, slat_geos5_tamp_v1 - use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp - use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa - use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 - use cires_ugwpv1_oro, only: orogw_v1 + use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp + use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa + use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 + use cires_ugwpv1_oro, only: orogw_v1 use drag_suite, only: drag_suite_run @@ -69,13 +69,13 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & - con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) - + use ugwp_common - + !---- initialization of unified_ugwp implicit none @@ -92,9 +92,9 @@ subroutine ugwpv1_gsldrag_init ( & real(kind=kind_phys), intent (in) :: dtp real(kind=kind_phys), intent (in) :: con_p0, con_pi, con_rerth - real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt + real(kind=kind_phys), intent(in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt logical, intent (in) :: do_ugwp - + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, & @@ -115,20 +115,20 @@ subroutine ugwpv1_gsldrag_init ( & errmsg = '' errflg = 0 !============================================================================ -! +! ! gwd_opt => "1 and 2, 3, 22, 33' see previous GSL-commits -! related to GSL-oro drag suite -! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography -! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 +! related to GSL-oro drag suite +! for use of the new-GSL/old-GFS/EMC inputs for sub-grid orography +! see details inside /ufs-weather-model/FV3/io/FV3GFS_io.F90 ! FV3GFS_io.F90: if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & ! FV3GFS_io.F90: Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then ! FV3GFS_io.F90: if ( (Model%gwd_opt==3 .or. Model%gwd_opt==33) .or. & ! FV3GFS_io.F90: ( (Model%gwd_opt==2 .or. Model%gwd_opt==22) .and. & ! ! gwd_opt=1 -current 14-element GFS-EMC subgrid-oro input -! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input +! gwd_opt=2 and 3 24-element -current 14-element GFS-EMC subgrid-oro input ! GSL uses the gwd_opt flag to control "extra" diagnostics (22 and 33) -! CCPP may use gwd_opt to determine 14 or 24 variables for the input +! CCPP may use gwd_opt to determine 14 or 24 variables for the input ! but at present you work with "nmtvr" ! GFS_GWD_generic.F90: integer, intent(in) :: im, levs, nmtvr !GFS_GWD_generic.F90: real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) @@ -136,7 +136,7 @@ subroutine ugwpv1_gsldrag_init ( & !GFS_GWD_generic.F90: elseif (nmtvr == 10) then ???? !GFS_GWD_generic.F90: elseif (nmtvr == 6) then ???? !GFS_GWD_generic.F90: elseif (nmtvr == 24) then ! GSD_drag_suite and unified_ugwp gwd_opt=2,3 -! +! ! 1) gsldrag: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1 ! 2) CIRES-v1: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp !============================================================================== @@ -156,25 +156,25 @@ subroutine ugwpv1_gsldrag_init ( & return end if -! +! if ( do_ugwp_v0_orog_only .or. do_ugwp_v0) then - print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 - print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only + print *, ' ccpp do_ugwp_v0 active ', do_ugwp_v0 + print *, ' ccpp do_ugwp_v1_orog_only active ', do_ugwp_v0_orog_only write(errmsg,'(*(a))') " the CIRES CCPP-suite does not & - support schemes " + support schemes " errflg = 1 - return + return endif -! +! if (do_ugwp_v1_w_gsldrag .and. do_ugwp_v1_orog_only ) then - + print *, ' do_ugwp_v1_w_gsldrag ', do_ugwp_v1_w_gsldrag print *, ' do_ugwp_v1_orog_only ', do_ugwp_v1_orog_only - print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl + print *, ' do_gsl_drag_ls_bl ',do_gsl_drag_ls_bl write(errmsg,'(*(a))') " the CIRES CCPP-suite intend to & - support with but has Logic error" + support with but has Logic error" errflg = 1 - return + return endif !========================== ! @@ -191,64 +191,64 @@ subroutine ugwpv1_gsldrag_init ( & cpd = con_cp rd = con_rd rv = con_rv - fv = con_fvirt - - grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav + fv = con_fvirt + + grav2 = grav + grav; rgrav = 1.0/grav ; rgrav2 = rgrav*rgrav rdi = 1.0 / rd ; rcpd = 1./cpd; rcpd2 = 0.5/cpd - gor = grav/rd + gor = grav/rd gr2 = grav*gor grcp = grav*rcpd gocp = grcp - rcpdl = cpd*rgrav + rcpdl = cpd*rgrav grav2cpd = grav*grcp - - pi2 = 2.*pi ; pih = .5*pi + + pi2 = 2.*pi ; pih = .5*pi rad_to_deg=180.0/pi deg_to_rad=pi/180.0 - + bnv2min = (pi2/1800.)*(pi2/1800.) bnv2max = (pi2/30.)*(pi2/30.) - dw2min = 1.0 + dw2min = 1.0 velmin = sqrt(dw2min) minvel = 0.5 - + omega2 = 2.*omega1 omega3 = 3.*omega1 - + hpscale = 7000. ; hpskm = hpscale*1.e-3 rhp = 1./hpscale - rhp2 = 0.5*rhp; rh4 = 0.25*rhp + rhp2 = 0.5*rhp; rh4 = 0.25*rhp rhp4 = rhp2 * rhp2 - khp = rhp* rd/cpd + khp = rhp* rd/cpd mkzmin = pi2/80.0e3 mkz2min = mkzmin*mkzmin mkzmax = pi2/500. mkz2max = mkzmax*mkzmax - cdmin = 2.e-2/mkzmax - + cdmin = 2.e-2/mkzmax + rcpdt = rcpd/dtp if ( do_ugwp_v1 ) then call cires_ugwpv1_init (me, master, nlunit, logunit, jdat, con_pi, & con_rerth, fn_nml2, lonr, latr, levs, ak, bk, & - con_p0, dtp, errmsg, errflg) + con_p0, dtp, errmsg, errflg) end if - + if (me == master) then print *, ' ccpp: ugwpv1_gsldrag_init ' - - print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 - print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl - print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss - print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd - - print *, ' ccpp: ugwpv1_gsldrag_init ' + + print *, ' ccpp do_ugwp_v1 flag ', do_ugwp_v1 + print *, ' ccpp do_gsl_drag_ls_bl flag ', do_gsl_drag_ls_bl + print *, ' ccpp do_gsl_drag_ss flag ' , do_gsl_drag_ss + print *, ' ccpp do_gsl_drag_tofd flag ', do_gsl_drag_tofd + + print *, ' ccpp: ugwpv1_gsldrag_init ' endif - - - is_initialized = .true. - + + + is_initialized = .true. + end subroutine ugwpv1_gsldrag_init @@ -303,7 +303,7 @@ end subroutine ugwpv1_gsldrag_finalize !! !> \section gen_ugwpv1_gsldrag CIRES UGWP Scheme General Algorithm !! @{ - subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & + subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kdt, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd, do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & gwd_opt, do_tofd, ldiag_ugwp, cdmbgwd, jdat, & @@ -316,22 +316,22 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd dudt_obl, dvdt_obl, du_oblcol, dv_oblcol, & dudt_oss, dvdt_oss, du_osscol, dv_osscol, & dudt_ofd, dvdt_ofd, du_ofdcol, dv_ofdcol, & - dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & - tau_ogw, tau_ngw, tau_oss, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, dudt_gw, dvdt_gw, dtdt_gw, kdis_gw, & + tau_ogw, tau_ngw, tau_oss, & zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw, ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw, & - lprnt, ipr, errmsg, errflg) + lprnt, ipr, errmsg, errflg) ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside ! ! a) /FV3/gfsphysics/GFS_layer/GFS_typedefs.meta ! b) /FV3/gfsphysics/GFS_layer/GFS_typedefs.F90 -! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" +! c) /FV3/gfsphysics/GFS_layer/GFS_diagnostics.F90 "diag-cs is not tested" !######################################################################## -! - +! + use ugwp_common, only : con_pi => pi, con_g => grav, con_rd => rd, & con_rv => rv, con_cp => cpd, con_fv => fv, & con_rerth => arad, con_omega => omega1, rgrav @@ -340,7 +340,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Preference use (im,levs) rather than (:,:) to avoid memory-leaks ! that found in Nov-Dec 2020 -! order array-description control-logical +! order array-description control-logical ! other in-variables ! out-variables ! local-variables @@ -349,17 +349,17 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! ! interface variables - logical, intent(in) :: ldiag3d, lssav - logical, intent(in) :: flag_for_gwd_generic_tend + logical, intent(in) :: ldiag3d, lssav + logical, intent(in) :: flag_for_gwd_generic_tend logical, intent(in) :: lprnt - + integer, intent(in) :: ipr - + ! flags for choosing combination of GW drag schemes to run - - logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd - logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp - logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes + + logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd + logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd, ldiag_ugwp + logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes integer, intent(in) :: me, master, im, levs, ntrac,lonr real(kind=kind_phys), intent(in) :: dtp, fhzero @@ -369,9 +369,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd integer, intent(in) :: gwd_opt !gwd_opt and nmtvr are "redundant" controls integer, intent(in) :: nmtvr real(kind=kind_phys), intent(in) :: cdmbgwd(4) ! for gsl_drag - + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc, theta, sigma, gamma - + real(kind=kind_phys), intent(in), dimension(im) :: elvmax real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 @@ -383,30 +383,30 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !===== ! real(kind=kind_phys), intent(in) :: con_g, con_omega, con_pi, con_cp, con_rd, & ! con_rv, con_rerth, con_fvirt -! grids +! grids real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area -! State vars + PBL/slmsk +rain +! State vars + PBL/slmsk +rain real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii real(kind=kind_phys), intent(in), dimension(im, levs) :: q1 integer, intent(in), dimension(im) :: kpbl - + real(kind=kind_phys), intent(in), dimension(im) :: rain - real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk + real(kind=kind_phys), intent(in), dimension(im) :: br1, hpbl, slmsk ! ! moved to GFS_phys_time_vary ! real(kind=kind_phys), intent(in), dimension(im) :: ddy_j1tau, ddy_j2tau -! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau - real(kind=kind_phys), intent(in), dimension(im) :: tau_amf - +! integer, intent(in), dimension(im) :: jindx1_tau, jindx2_tau + real(kind=kind_phys), intent(in), dimension(im) :: tau_amf + !Output (optional): real(kind=kind_phys), intent(out), dimension(im) :: & - du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & - du_osscol, dv_osscol, du_ofdcol, dv_ofdcol + du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & + du_osscol, dv_osscol, du_ofdcol, dv_ofdcol ! ! we may add later but due to launch in the upper layes ~ mPa comparing to ORO Pa*(0.1) ! du_ngwcol, dv_ngwcol @@ -420,12 +420,12 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_ngw, dvdt_ngw, kdis_ngw real(kind=kind_phys), intent(out) , dimension(im, levs) :: dudt_gw, dvdt_gw, kdis_gw - - real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw - + + real(kind=kind_phys), intent(out) , dimension(im, levs) :: dtdt_ngw, dtdt_gw + real(kind=kind_phys), intent(out) , dimension(im) :: zogw, zlwb, zobl, zngw -! -! +! +! real(kind=kind_phys), intent(inout), dimension(im, levs) :: dudt, dvdt, dtdt ! @@ -435,7 +435,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw - + real(kind=kind_phys), intent(out), dimension(im) :: rdxzb ! for stoch phys. mtb-level @@ -445,22 +445,22 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! local variables integer :: i, k - real(kind=kind_phys), dimension(im) :: sgh30 + real(kind=kind_phys), dimension(im) :: sgh30 real(kind=kind_phys), dimension(im, levs) :: Pdvdt, Pdudt real(kind=kind_phys), dimension(im, levs) :: Pdtdt, Pkdis !------------ ! ! from ugwp_driver_v0.f -> cires_ugwp_initialize.F90 -> module ugwp_wmsdis_init -! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa +! now in the namelist of cires_ugwp "knob_ugwp_tauamp" controls tamp_mpa ! ! tamp_mpa =knob_ugwp_tauamp !amplitude for GEOS-5/MERRA-2 !------------ ! real(kind=kind_phys), parameter :: tamp_mpa_v0=30.e-3 ! large flux to help "GFS-ensembles" in July 2019 ! switches that activate impact of OGWs and NGWs - + ! integer :: nmtvr_temp - + real(kind=kind_phys), dimension(im, levs) :: zmet ! geopotential height at model Layer centers real(kind=kind_phys), dimension(im, levs+1) :: zmeti ! geopotential height at model layer interfaces @@ -476,45 +476,45 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! Initialize CCPP error handling variables - + errmsg = '' errflg = 0 ! 1) ORO stationary GWs ! ------------------ -! +! ! for all oro-suites can uze geo-meters having "hpbl" -! +! ! ! All GW-schemes operate with Zmet =phil*inv_g, passing Zmet/Zmeti can be more robust ! + rho*dz = =delp * inv_g can be also pre-comp for all "GW-schemes" ! zmeti = phii* rgrav zmet = phil* rgrav - + !=============================================================== ! ORO-diag - - dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. - dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. - - dusfcg (:) = 0. ; dvsfcg(:) =0. - - du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. - du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. - -! - dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. - -! ngw+ogw - diag - - dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. + + dudt_ogw(:,:) = 0. ; dvdt_ogw(:,:)=0. ; dudt_obl(:,:)=0. ; dvdt_obl(:,:)=0. + dudt_oss(:,:) = 0. ; dvdt_oss(:,:)=0. ; dudt_ofd(:,:)=0. ; dvdt_ofd(:,:)=0. + + dusfcg (:) = 0. ; dvsfcg(:) =0. + + du_ogwcol(:)=0. ; dv_ogwcol(:)=0. ; du_oblcol(:)=0. ; dv_oblcol(:)=0. + du_osscol(:)=0. ; dv_osscol(:)=0. ;du_ofdcol(:)=0. ; dv_ofdcol(:)=0. + +! + dudt_ngw(:,:)=0. ; dvdt_ngw(:,:)=0. ; dtdt_ngw(:,:)=0. ; kdis_ngw(:,:)=0. + +! ngw+ogw - diag + + dudt_gw(:,:)=0. ; dvdt_gw(:,:)=0. ; dtdt_gw(:,:)=0. ; kdis_gw(:,:)=0. ! source fluxes - - tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. - + + tau_ogw(:)=0. ; tau_ngw(:)=0. ; tau_oss(:)=0. + ! launch layers - + zlwb(:)= 0. ; zogw(:)=0. ; zobl(:)=0. ; zngw(:)=0. !=============================================================== ! diag tendencies due to all-SSO schemes (ORO-physics) @@ -525,10 +525,10 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd Pdvdt(i,k) = 0.0 Pdudt(i,k) = 0.0 Pdtdt(i,k) = 0.0 - Pkdis(i,k) = 0.0 + Pkdis(i,k) = 0.0 enddo enddo -! +! ! Run the appropriate large-scale (large-scale GWD + blocking) scheme ! Note: In case of GSL drag_suite, this includes ss and tofd @@ -539,7 +539,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! dudt_ogw, dvdt_ogw, dudt_obl, dvdt_obl,dudt_oss, dvdt_oss, dudt_ofd, dvdt_ofd ! du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, du_osscol, dv_osscol, du_ofdcol dv_ofdcol ! dusfcg, dvsfcg -! +! ! call drag_suite_run(im,levs, Pdvdt, Pdudt, Pdtdt, & ugrs,vgrs,tgrs,q1, & @@ -556,33 +556,33 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd cdmbgwd(1:2),me,master,lprnt,ipr,rdxzb,dx,gwd_opt, & do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & errmsg,errflg) -! +! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol -! -! if (kdt <= 2 .and. me == master) then -! print *, ' unified drag_suite_run ', kdt -! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 -! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 -! -! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 -! -! if (gwd_opt == 22 .or. gwd_opt == 33) then -! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 -! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 -! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 -! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 -! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 -! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 -! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 -! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 -! endif -! endif - - else +! +! if (kdt <= 2 .and. me == master) then +! print *, ' unified drag_suite_run ', kdt +! print *, ' GSL drag du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' GSL drag dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! +! zero print *, ' unified drag_GSL dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! +! if (gwd_opt == 22 .or. gwd_opt == 33) then +! print *, ' unified drag_GSL dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified drag_GSL dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! print *, ' unified drag_GSL dUOGW/dt ', maxval(dudt_ogw)*86400, minval(dudt_ogw)*86400 +! print *, ' unified drag_GSL dVOGW/dt ', maxval(dvdt_ogw)*86400, minval(dvdt_ogw)*86400 +! print *, ' unified drag_GSL dUOss/dt ', maxval(dudt_oss)*86400, minval(dudt_oss)*86400 +! print *, ' unified drag_GSL dVOSS/dt ', maxval(dvdt_oss)*86400, minval(dvdt_oss)*86400 +! print *, ' unified drag_GSL dUOfd/dt ', maxval(dudt_ofd)*86400, minval(dudt_ofd)*86400 +! print *, ' unified drag_GSL dVOfd/dt ', maxval(dvdt_ofd)*86400, minval(dvdt_ofd)*86400 +! endif +! endif + + else ! ! not gsldrag oro-scheme for example "do_ugwp_v1_orog_only" -! - +! + if ( do_ugwp_v1_orog_only ) then ! ! for TOFD we use now "varss" of GSL-drag /not sgh30=abs(oro-oro_f)/ @@ -591,38 +591,38 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! OROGW_V1 introduce "orchestration" between OGW-effects and Mountain Blocking ! it starts to examines options for the Scale-Aware (SA)formulation of SSO-effects ! if ( me == master .and. kdt == 1) print *, ' bf orogw_v1 nmtvr=', nmtvr, ' do_tofd=', do_tofd - + if (gwd_opt ==1 )sgh30 = 0.15*hprime ! portion of the mesoscale SSO (~[oro_unfilt -oro_filt) if (gwd_opt >1 ) sgh30 = varss ! as in gsldrag: see drag_suite_run - + call orogw_v1 (im, levs, lonr, me, master,dtp, kdt, do_tofd, & xlat_d, sinlat, coslat, area, & cdmbgwd(1:2), hprime, oc, oa4, clx, theta, & - sigma, gamma, elvmax, sgh30, kpbl, ugrs, & - vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & - Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & + sigma, gamma, elvmax, sgh30, kpbl, ugrs, & + vgrs, tgrs, q1, prsi,del,prsl,prslk, zmeti, zmet, & + Pdvdt, Pdudt, Pdtdt, Pkdis, DUSFCg, DVSFCg,rdxzb, & zobl, zlwb, zogw, tau_ogw, dudt_ogw, dvdt_ogw, & dudt_obl, dvdt_obl,dudt_ofd, dvdt_ofd, & du_ogwcol, dv_ogwcol, du_oblcol, dv_oblcol, & du_ofdcol, dv_ofdcol, errmsg,errflg ) -! +! ! orogw_v1: dusfcg = du_ogwcol + du_oblcol + du_ofdcol only 3 terms ! ! ! if (kdt <= 2 .and. me == master) then -! -! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr -! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 -! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 -! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 -! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 -! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 -! endif - - +! +! print *, ' unified_ugwp orogw_v1 ', kdt, me, nmtvr +! print *, ' unified_ugwp orogw_v1 du/dt ', maxval(Pdudt)*86400, minval(Pdudt)*86400 +! print *, ' unified_ugwp orogw_v1 dv/dt ', maxval(Pdvdt)*86400, minval(Pdvdt)*86400 +! print *, ' unified_ugwp orogw_v1 dT/dt ', maxval(Pdtdt)*86400, minval(Pdtdt)*86400 +! print *, ' unified_ugwp orogw_v1 dUBL/dt ', maxval(dudt_obl)*86400, minval(dudt_obl)*86400 +! print *, ' unified_ugwp orogw_v1 dVBL/dt ', maxval(dvdt_obl)*86400, minval(dvdt_obl)*86400 +! endif + + end if ! -! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections +! for old-fashioned GFS-style diag-cs like dt3dt(:.:, 1:14) collections ! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs @@ -633,7 +633,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - ENDIF + ENDIF ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Begin non-stationary GW schemes @@ -641,54 +641,54 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (do_ugwp_v1) then - -!================================================================== -! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) + +!================================================================== +! call slat_geos5_tamp_v1(im, tamp_mpa, xlat_d, tau_ngw) ! ! 2020 updates of MERRA/GEOS tau_ngw for the C96-QBO FV3GFS-127L runs -!================================================================== - +!================================================================== + call slat_geos5_2020(im, tamp_mpa, xlat_d, tau_ngw) - y4 = jdat(1); month = jdat(2); day = jdat(3) -! -! hour = jdat(5) + y4 = jdat(1); month = jdat(2); day = jdat(3) +! +! hour = jdat(5) ! fhour = float(hour)+float(jdat(6))/60. + float(jdat(7))/3600. ! fhour = (kdt-1)*dtp/3600. ! fhrday = fhour/24. - nint(fhour/24.) - - - call calendar_ugwp(y4, month, day, ddd_ugwp) + + + call calendar_ugwp(y4, month, day, ddd_ugwp) curdate = y4*1000 + ddd_ugwp -! +! call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & - tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) - + tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & zmet, zmeti,prslk, xlat_d, sinlat, coslat, & dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) -! +! ! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt ! ! if (me == master .and. kdt <= 2) then ! print * ! write(6,*)'FV3GFS finished fv3_ugwp_solv2_v1 ' ! write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' -! print * -! -! print *, ' ugwp_v1 ', kdt -! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 -! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 -! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 +! print * +! +! print *, ' ugwp_v1 ', kdt +! print *, ' ugwp_v1 du/dt ', maxval(dudt_ngw)*86400, minval(dudt_ngw)*86400 +! print *, ' ugwp_v1 dv/dt ', maxval(dvdt_ngw)*86400, minval(dvdt_ngw)*86400 +! print *, ' ugwp_v1 dT/dt ', maxval(dtdt_ngw)*86400, minval(dtdt_ngw)*86400 ! endif - + end if ! do_ugwp_v1 - + ! ! GFS-style diag dt3dt(:.:, 1:14) time-averaged -! +! if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then do k=1,levs do i=1,im @@ -698,21 +698,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd enddo enddo endif - + ! ! get total sso-OGW + NGW ! dudt_gw = Pdudt +dudt_ngw dvdt_gw = Pdvdt +dvdt_ngw - dtdt_gw = Pdtdt +dtdt_ngw - kdis_gw = Pkdis +kdis_ngw + dtdt_gw = Pdtdt +dtdt_ngw + kdis_gw = Pkdis +kdis_ngw ! -! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) +! accumulate "tendencies" as in the GFS-ipd (pbl + ugwp + zero-RF) ! dudt = dudt + dudt_ngw - dvdt = dvdt + dvdt_ngw - dtdt = dtdt + dtdt_ngw - + dvdt = dvdt + dvdt_ngw + dtdt = dtdt + dtdt_ngw + end subroutine ugwpv1_gsldrag_run !! @} !>@} From ea77544735b4c07ac59ee9a477f4e435eaa42569 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 11 Feb 2021 15:54:52 -0700 Subject: [PATCH 63/67] physics/ugwpv1_gsldrag.F90: adjust formatting --- physics/ugwpv1_gsldrag.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 24ab2b2d1..87cbbb853 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -69,7 +69,7 @@ subroutine ugwpv1_gsldrag_init ( & me, master, nlunit, input_nml_file, logunit, & fn_nml2, jdat, lonr, latr, levs, ak, bk, dtp, & con_pi, con_rerth, con_p0, & - con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & + con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) From 04ecde307c086c8ff49105757a506ccdfc561457 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 12 Feb 2021 15:02:42 -0700 Subject: [PATCH 64/67] Bugfix in physics/ugwpv1_gsldrag.F90, 3d diagnostic arrays may not be allocated --- physics/ugwpv1_gsldrag.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 87cbbb853..00fd42dbd 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -433,8 +433,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd ! ! Version of COORDE updated by CCPP-dev for time-aver ! - real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw - real(kind=kind_phys), intent(inout), dimension(im,levs) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ogw, ldv3dt_ogw, ldt3dt_ogw + real(kind=kind_phys), intent(inout), dimension(:,:) :: ldu3dt_ngw, ldv3dt_ngw, ldt3dt_ngw From 8e4caf10a39ac7530e7c0eabc0aa1e0dd8deb959 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 16 Feb 2021 07:20:08 -0700 Subject: [PATCH 65/67] Bugfix in physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5ecc9d8a3..3e8e987c7 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -681,6 +681,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtdt_gw ', Diag%dtdt_gw) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%kdis_gw ', Diag%kdis_gw) if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_obl ', Diag%dudt_obl ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_obl ', Diag%dvdt_obl ) @@ -697,7 +698,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du_ofdcol ', Diag%du_ofdcol) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv_ofdcol ', Diag%dv_ofdcol) else - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvdt_ogw ', Diag%dvdt_ogw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dudt_ogw ', Diag%dudt_ogw) end if ! Statein call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) @@ -1264,7 +1265,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_oss ', Interstitial%tau_oss ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) From 8cc60d34c49426b78d2fe14a9c16fc719c558041 Mon Sep 17 00:00:00 2001 From: Ruiyu Sun Date: Wed, 17 Feb 2021 17:17:16 +0000 Subject: [PATCH 66/67] a bug fix in radiation_clouds.f for Thompson MP --- physics/radiation_clouds.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 056bede28..dacf6e38e 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3189,7 +3189,7 @@ subroutine progcld6 & endif ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if ( iovr == 4 .or. iovr == 5) then + if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) else de_lgth(:) = 0. From be017d02cc0fc17f9c0a302693076149c9f21c8c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 22 Feb 2021 10:28:20 -0700 Subject: [PATCH 67/67] Revert change to CODEOWNERS --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 0d5230f89..b6c597371 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @climbfuji @llpcarson @grantfirl @JulieSchramm +* @DomHeinzeller # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners