diff --git a/Registry/Registry.EM_COMMON b/Registry/Registry.EM_COMMON index 97a3716191..383157360c 100644 --- a/Registry/Registry.EM_COMMON +++ b/Registry/Registry.EM_COMMON @@ -98,6 +98,7 @@ state real sct_dom_gc ij dyn_em 1 - i1 "SCT_DOM" state real scb_dom_gc ij dyn_em 1 - i1 "SCB_DOM" "Dominant soil (bottom) category from GEOGRID" "cat" state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" + state real lai12m imj dyn_em 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" state real pdrho_gc igj dyn_em 1 Z - "PDRHO" "dry pressure for UM data for the variables U and V" "Pa" @@ -543,6 +544,12 @@ state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real qvolh ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" +state real qzr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZRAIN" "Sixth moment rain" "m(6) kg(-1)" +state real qzg ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZGRAUPEL" "Sixth moment graupel" "m(6) kg(-1)" +state real qzh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZHAIL" "Sixth moment hail" "m(6) kg(-1)" state real qrimef ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QRIMEF" "rime factor * qi" "kg kg-1" state real qir ikjftb scalar 1 - \ @@ -591,6 +598,12 @@ state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qzr ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZRAIN" "DFI Rain Reflectivity" "m(6) kg(-1)" +state real dfi_qzg ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZGRAUPEL" "DFI Graupel Reflectivity" "m(6) kg(-1)" +state real dfi_qzh ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZHAIL" "DFI Hail Reflectivity" "m(6) kg(-1)" state real dfi_qvolg ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "DFI Graupel Particle Volume" "m(3) kg(-1)" state real dfi_qvolh ikjftb dfi_scalar 1 - \ @@ -2289,6 +2302,7 @@ rconfig integer interp_method_type namelist,domains 1 2 rconfig logical aggregate_lu namelist,domains 1 .false. irh "aggregate_lu" "T/F aggregate the grass, shrubs, trees in LU" rconfig logical rh2qv_wrt_liquid namelist,domains 1 .true. irh "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice" rconfig integer rh2qv_method namelist,domains 1 1 irh "rh2qv_method" "1=old MM5 method, 2=new WMO method" +rconfig logical use_sh_qv namelist,domains 1 .false. irh "use_sh_qv" "T/F whether to use SH or mixing ratio in input" rconfig real qv_max_p_safe namelist,domains 1 10000 irh "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value" "Pa" rconfig real qv_max_flag namelist,domains 1 1.E-5 irh "qv_max_flag" "Qv flag for max" "kg kg{-1}" rconfig real qv_max_value namelist,domains 1 3.E-6 irh "qv_max_value" "Qv value for max" "kg kg{-1}" @@ -2391,16 +2405,27 @@ rconfig logical write_thompson_tables namelist,physics 1 .tru rconfig logical write_thompson_mp38table namelist,physics 1 .false. rconfig integer mp_physics namelist,physics max_domains -1 irh "mp_physics" "" "" #rconfig integer milbrandt_ccntype namelist,physics max_domains 0 rh "milbrandt select maritime(1)/continental(2)" "" "" -rconfig real nssl_cccn namelist,physics max_domains 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" -rconfig real nssl_alphah namelist,physics max_domains 0 rh "Graupel PSD shape paramter" "" "" -rconfig real nssl_alphahl namelist,physics max_domains 1 rh "Hail PSD shape paramter" "" "" -rconfig real nssl_cnoh namelist,physics max_domains 4.e5 rh "Graupel intercept paramter" "" "" -rconfig real nssl_cnohl namelist,physics max_domains 4.e4 rh "Hail intercept paramter" "" "" -rconfig real nssl_cnor namelist,physics max_domains 8.e5 rh "Rain intercept paramter" "" "" -rconfig real nssl_cnos namelist,physics max_domains 3.e6 rh "Snow intercept paramter" "" "" -rconfig real nssl_rho_qh namelist,physics max_domains 500. rh "Graupel particle density" "" "" -rconfig real nssl_rho_qhl namelist,physics max_domains 900. rh "Hail particle density" "" "" -rconfig real nssl_rho_qs namelist,physics max_domains 100. rh "Snow particle density" "" "" +rconfig real nssl_cccn namelist,physics 1 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" +rconfig real nssl_alphah namelist,physics 1 0 rh "Graupel PSD shape paramter" "" "" +rconfig real nssl_alphahl namelist,physics 1 1 rh "Hail PSD shape paramter" "" "" +rconfig real nssl_cnoh namelist,physics 1 4.e5 rh "Graupel intercept paramter" "" "" +rconfig real nssl_cnohl namelist,physics 1 4.e4 rh "Hail intercept paramter" "" "" +rconfig real nssl_cnor namelist,physics 1 8.e5 rh "Rain intercept paramter" "" "" +rconfig real nssl_cnos namelist,physics 1 3.e6 rh "Snow intercept paramter" "" "" +rconfig real nssl_rho_qh namelist,physics 1 500. rh "Graupel particle density" "" "" +rconfig real nssl_rho_qhl namelist,physics 1 900. rh "Hail particle density" "" "" +rconfig real nssl_rho_qs namelist,physics 1 100. rh "Snow particle density" "" "" +rconfig integer nssl_icdx namelist,physics 1 6 rh "NSSL Graupel fall speed option" "" "" +rconfig integer nssl_icdxhl namelist,physics 1 6 rh "NSSL Hail fall speed option" "" "" +rconfig integer nssl_hail_on namelist,physics max_domains -1 rh "NSSL Hail flag" "" "" +rconfig integer nssl_ccn_on namelist,physics 1 -1 rh "NSSL CCN flag" "" "" +rconfig integer nssl_ccn_is_ccna namelist,physics 1 0 rh "NSSL flag that CCN is CCNA" "" "" +rconfig integer nssl_2moment_on namelist,physics 1 -1 rh "NSSL 2-moment flag" "" "" +rconfig integer nssl_3moment namelist,physics 1 0 rh "NSSL 3-moment flag" "" "" +rconfig integer nssl_density_on namelist,physics 1 -1 rh "NSSL graupel/hail density flag" "" "" + + + rconfig integer CCNTY namelist,physics 1 2 rh "Aerosol background type for NTU microphysics" "" "" # Lightning Qv Nudging @@ -3003,11 +3028,8 @@ package cammgmpscheme mp_physics==11 - moist:qv,qc package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow -package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg -package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg -package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package wsm7scheme mp_physics==24 - moist:qv,qc,qr,qi,qs,qg,qh;state:re_cloud,re_ice,re_snow package wdm7scheme mp_physics==26 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa,qnbca;state:re_cloud,re_ice,re_snow,qnwfa2d,qnifa2d,taod5503d,taod5502d @@ -3023,6 +3045,16 @@ package etampnew mp_physics==95 - moist:qv,qc package gsfcgcescheme mp_physics==97 - moist:qv,qc,qr,qi,qs,qg package madwrf_mp mp_physics==96 - moist:qv,qc,qi,qs +package nssl2mconc nssl_2moment_on==1 - scalar:qndrop,qnr,qni,qns,qng;state:re_cloud,re_ice,re_snow +package nssl3mg nssl_3moment==1 - scalar:qzr,qzg +package nssl3m nssl_3moment==2 - scalar:qzr,qzg,qzh +package nssl_hail nssl_hail_on==1 - moist:qh;scalar:qnh +package nssl_hail1m nssl_hail_on==2 - moist:qh; +package nssl_ccn_opt nssl_ccn_on==1 - scalar:qnn +package nssl_graupelvol nssl_density_on==1 - scalar:qvolg +package nssl_hailvol nssl_density_on==2 - scalar:qvolg,qvolh + + package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max endif @@ -3046,10 +3078,12 @@ package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi #package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg -package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +#package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +#package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dfi mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +#package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg +#package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +#package nssl_2momg_dfi mp_physics_dfi==22 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm7scheme_dfi mp_physics_dfi==24 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm7scheme_dfi mp_physics_dfi==26 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa,dfi_qnbca;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -3345,6 +3379,8 @@ package wrfhydro wrf_hydro==1 - state:SOLDRAIN #WRF Windfarm package no_windfarm windfarm_opt==0 - - package fitchscheme windfarm_opt==1 - state:power +# Yulong add for WLM +package mavscheme windfarm_opt==2 - state:power #Ideal Cases package realcase ideal_case==0 - - @@ -3610,3 +3646,10 @@ xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy package no_fft_used fft_used==0 - - package any_fft_used fft_used==1 - state:t_xxx,u_xxx,ru_xxx,v_xxx,rv_xxx,w_xxx,ww_xxx,ph_xxx,dum_yyy,fourd_xxx +# Yulong add for wind wake models +# 1 = Jensen; 2 = XA; 3 = GM +rconfig integer windfarm_wake_model namelist,physics max_domains 2 rh "windfarm_wake_model" "" "" +# +# wake overlap method, M1, M2, M3, M4 [1, 2, 3, 4] +rconfig integer windfarm_overlap_method namelist,physics max_domains 4 rh "windfarm_overlap_method" "" "" +rconfig real windfarm_deg namelist,physics max_domains 0 - "windfarm_deg" "for windfarm ideal case" "degree" diff --git a/Registry/registry.chem b/Registry/registry.chem index 70586eae72..6cd996156b 100644 --- a/Registry/registry.chem +++ b/Registry/registry.chem @@ -82,7 +82,7 @@ state real e_hcho i+jf emis_ant 1 Z i5r "E_H state real e_ald i+jf emis_ant 1 Z i5r "E_ALD" "EMISSIONS" "mol km^-2 hr^-1" state real e_ket i+jf emis_ant 1 Z i5r "E_KET" "EMISSIONS" "mol km^-2 hr^-1" state real e_ora2 i+jf emis_ant 1 Z i5r "E_ORA2" "EMISSIONS" "mol km^-2 hr^-1" -state real e_nh3 i+jf emis_ant 1 Z i5r "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" +state real e_nh3 i+jf emis_ant 1 Z i5rh01 "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" state real e_pm_25 i+jf emis_ant 1 Z i5r "E_PM_25" "EMISSIONS" "ug/m3 m/s" state real e_pm_10 i+jf emis_ant 1 Z i5r "E_PM_10" "EMISSIONS" "ug/m3 m/s" state real e_pm25i i+jf emis_ant 1 Z i5r "E_PM25I" "EMISSION RATE OF UNIDEN. PM2.5 MASS" "ug/m3 m/s" @@ -213,7 +213,7 @@ state real setvel_1 ij misc 1 - r "set state real setvel_2 ij misc 1 - r "setvel_2" "dust gravitational settling velocity for size 2" "m/s" state real setvel_3 ij misc 1 - r "setvel_3" "dust gravitational settling velocity for size 3" "m/s" state real setvel_4 ij misc 1 - r "setvel_4" "dust gravitational settling velocity for size 4" "m/s" -state real setvel_5 ij misc 1 - r "setvel_5" "effective gravitational settling velocity for total" "m/s" +state real setvel_5 ij misc 1 - r "setvel_5" "dust gravitational settling velocity for size 5" "m/s" state real dustgraset_1 ij misc 1 - r "graset_1" "Accumulated dust gravitational settling for size 1" "kg/m2" state real dustgraset_2 ij misc 1 - r "graset_2" "Accumulated dust gravitational settling for size 2" "kg/m2" state real dustgraset_3 ij misc 1 - r "graset_3" "Accumulated dust gravitational settling for size 3" "kg/m2" @@ -670,6 +670,17 @@ state real pftp_hb ij misc 1 - i06r "pft state real mtsa ijm misc 1 Z i06r "mtsa" "Monthly surface air temp" "K" state real mswdown ijm misc 1 Z i06r "mswdown" "Monthly SWdown" "W/m2" state real EFmegan ij{nm} misc 1 - - "EFmegan" "MEGAN2 Emis Factor" "ug m^-2 hr^-1" +# Arrays for online ammonia emissions +state real EFnh3 ij misc 1 - i01rh01 "EFNH3" "NH3 Emis Factor" "ug m^-2 hr^-1" +state real actnh3 imj misc 1 Z i01rh01d "ACTNH3" "The activity of NH3" "0 - 1 fraction" +state real agrisoil_nh3 ij misc 1 Z i01rh01d "AGRISOIL_NH3" "The activity of NH3" "0 - 1 fraction" +state real fertilizer_nh3 imj misc 1 Z i01rh01d "FERTILIZER_NH3" "The activity of NH3" "0 - 1 fraction" +state real freeinten_nh3 ij misc 1 Z i01rh01d "FREEINTEN_NH3" "The activity of NH3" "0 - 1 fraction" +state real graze_nh3 ij misc 1 Z i01rh01d "GRAZE_NH3" "The activity of NH3" "0 - 1 fraction" +state real industry_nh3 ij misc 1 Z i01rh01d "INDUSTRY_NH3" "The activity of NH3" "0 - 1 fraction" +state real residential_nh3 ij misc 1 Z i01rh01d "RESIDENTIAL_NH3" "The activity of NH3" "0 - 1 fraction" +state real transport_nh3 ij misc 1 Z i01rh01d "TRANSPORT_NH3" "The activity of NH3" "0 - 1 fraction" + # Input for GOCART: Background chemistry, erodible surface emissions map state real backg_oh ikj misc 1 - i08r "BACKG_OH" "Background OH for Aerosol-GOcart option" "volume mixing ratio" state real backg_h2o2 ikj misc 1 - i08r "BACKG_H2O2" "Background H2O2 for Aerosol-GOcart option" "volume mixing ratio" @@ -3832,6 +3843,10 @@ rconfig integer emiss_opt namelist,chem max_domains rconfig integer emiss_opt_vol namelist,chem max_domains 0 rh "emiss_opt_vol" "" "" rconfig integer dust_opt namelist,chem 1 0 rh "dust_opt" "" "" rconfig integer dust_schme namelist,chem 1 2 rh "dust_schme" "" "" + +#renchuanhua rch added +rconfig integer nh3emis_opt namelist,chem 1 0 rh "nh3emis_opt" "" "" + rconfig integer dmsemis_opt namelist,chem 1 0 rh "dmsemis_opt" "" "" rconfig integer seas_opt namelist,chem 1 0 rh "seas_opt" "" "" rconfig integer bio_emiss_opt namelist,chem max_domains 0 rh "bio_emiss_opt" "" "" @@ -3904,8 +3919,9 @@ rconfig integer mosaic_aerchem_optaa namelist,chem 1 rconfig real af_lambda_start namelist,chem max_domains 200. rh "start wavelength for AF output" "nm" "" rconfig real af_lambda_end namelist,chem max_domains 340. rh "end wavelength for AF output" "nm" "" # Control for ISORROPIA in MADE/SORGAM schemes + rconfig logical do_isorropia namelist,chem 1 .false. rh "flag to use ISORROPIA" -rconfig logical do_n2o5het namelsit,chem 1 .false. rh "flag to do n2o5 heterogenous chemistry via chlorine pathway" +rconfig logical do_n2o5het namelist,chem 1 .false. rh "flag to do n2o5 heterogenous chemistry via chlorine pathway" # CHEMISTRY PACKAGE DEFINITIONS # @@ -4085,6 +4101,10 @@ package beis314 bio_emiss_opt==2 - - package megan2 bio_emiss_opt==3 - state:mebio_isop,mebio_apin,mebio_bcar,mebio_acet,mebio_mbo,mebio_no,msebio_isop,mlai,pftp_bt,pftp_nt,pftp_sb,pftp_hb,mtsa,mswdown,EFmegan package megan2_clm bio_emiss_opt==4 +# renchuanhua rch added for online nh3 emissions +package offline nh3emis_opt==0 - - +package online nh3emis_opt==1 - state:EFnh3,agrisoil_nh3,fertilizer_nh3,freeinten_nh3,graze_nh3,industry_nh3,residential_nh3,transport_nh3;emis_ant:e_nh3 + # Biospheric CO2 and CH4 emissions package ebioco2 bio_emiss_opt==16 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;eghg_bio:ebio_gee,ebio_res,ebio_co2oce package ebioghg bio_emiss_opt==17 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;wet_in:cpool,wetmap,t_ann;eghg_bio:ebio_gee,ebio_res,ebio_co2oce,ebio_ch4wet,ebio_ch4soil,ebio_ch4term diff --git a/Registry/registry.fire b/Registry/registry.fire index 35a2284c35..6d1b33eb0a 100644 --- a/Registry/registry.fire +++ b/Registry/registry.fire @@ -221,6 +221,17 @@ rconfig integer fire_sprd_mdl namelist,fire max_domains rconfig real fire_crwn_hgt namelist,fire max_domains 15. - "fire_crwn_hgt" "height that heat from crown fire is released" "m" rconfig real fire_ext_grnd namelist,fire max_domains 50. - "fire_ext_grnd" "extinction depth of sfc fire heat" "m" rconfig real fire_ext_crwn namelist,fire max_domains 50. - "fire_ext_crwn" "extinction depth of crown fire heat" "m" +# +# ------------------------------------------------------------------------------------------------------------------------ +# variable for Truncated Gaussian dist. +# +rconfig integer fire_sfc_flx namelist,fire max_domains 0 - "fire_sfc_flx" "compute flux div according to 0=exponential decay, 1=Truncated Gaussian distribution" "" +rconfig real fire_heat_peak namelist,fire max_domains 0. - "fire_heat_peak" "ONLY fire_sfc_flx=1, the peak heat release height for the Truncated Gaussian scheme" "m AGL" +rconfig real fire_tg_ub namelist,fire max_domains 1000. - "fire_tg_ub" "The upper bpund of the Truncated Gaussian scheme; the default typically works well" "m AGL" +rconfig integer fire_smk_scheme namelist,fire max_domains 0 - "fire_smk_scheme" "Fire smoke release scheme; 0=tracers at first level, 1=Truncated Gaussian dist" +rconfig real fire_smk_peak namelist,fire max_domains 0. - "fire_smk_peak" "ONLY fire_smk_scheme=1, the peak smoke release height for the Truncated Gaussian scheme" "m AGL" +rconfig real fire_smk_ext namelist,fire max_domains 50. - "fire_smk_ext" "ONLY fire_smk_scheme=1, the extinction depth of smoke" "m AGL" + rconfig real fire_wind_height namelist,fire max_domains 6.096 - "fire_wind_height" "height of uah,vah wind in fire spread formula" "m" rconfig integer fire_fuel_read namelist,fire max_domains -1 - "fire_fuel_read" "fuel categories are set by: if 0, uniform; if 1, user-presc; if 2, read from file" "" rconfig integer fire_fuel_cat namelist,fire max_domains 1 - "fire_fuel_cat" "fuel category if ifuelread=0" "" diff --git a/Registry/registry.var b/Registry/registry.var index c3da95a13d..32cc1471db 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -202,6 +202,7 @@ rconfig logical use_amsr2obs namelist,wrfvar4 1 .false. - "use rconfig logical use_ahiobs namelist,wrfvar4 1 .false. - "use_ahiobs" "" "" rconfig logical use_gmiobs namelist,wrfvar4 1 .false. - "use_gmiobs" "" "" rconfig logical use_goesimgobs namelist,wrfvar4 1 .false. - "use_goesimgobs" "" "" +rconfig logical use_goesabiobs namelist,wrfvar4 1 .false. - "use_goesabiobs" "" "" rconfig logical use_kma1dvar namelist,wrfvar4 1 .false. - "use_kma1dvar" "" "" rconfig logical use_filtered_rad namelist,wrfvar4 1 .false. - "use_filtered_rad" "" "" rconfig logical use_obs_errfac namelist,wrfvar4 1 .false. - "use_obs_errfac" "" "" @@ -468,6 +469,7 @@ rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "va rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_zz namelist,wrfvar14 1 .false. - "use_clddet_zz" "cloud detection scheme from Zhuge X. and Zou X. JAMC, 2016." "" rconfig integer ahi_superob_halfwidth namelist,wrfvar14 1 0 - "ahi_superob_halfwidth" "" "" +rconfig integer abi_superob_halfwidth namelist,wrfvar14 1 0 - "abi_superob_halfwidth" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" @@ -477,6 +479,7 @@ rconfig character crtm_irwater_coef namelist,wrfvar14 1 "Nalli.IRwater rconfig character crtm_mwwater_coef namelist,wrfvar14 1 "FASTEM5.MWwater.EmisCoeff.bin" - "crtm_mwwater_coef" "" "" rconfig character crtm_irland_coef namelist,wrfvar14 1 "USGS.IRland.EmisCoeff.bin" - "crtm_irland_coef" "" "" rconfig character crtm_visland_coef namelist,wrfvar14 1 "USGS.VISland.EmisCoeff.bin" - "crtm_visland_coef" "" "" +rconfig logical abi_use_symm_obs_err namelist,wrfvar14 1 .false. - "abi_use_symm_obs_err" "" "" rconfig logical ahi_use_symm_obs_err namelist,wrfvar14 1 .false. - "ahi_use_symm_obs_err" "" "" rconfig logical ahi_apply_clrsky_bias namelist,wrfvar14 1 .false. - "ahi_apply_clrsky_bias" "" "" rconfig integer num_pseudo namelist,wrfvar15 1 0 - "num_pseudo" "" "" @@ -590,11 +593,8 @@ package cammgmpscheme mp_physics==11 - moist:qv,qc package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg -package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg package p3_1category mp_physics==50 - moist:qv,qc,qr,qi package p3_1category_nc mp_physics==51 - moist:qv,qc,qr,qi @@ -604,6 +604,7 @@ package ntu mp_physics==56 - moist:qv,qc package etampnew mp_physics==95 - moist:qv,qc,qr,qs package lscondscheme mp_physics==98 - moist:qv package mkesslerscheme mp_physics==99 - moist:qv,qc,qr + # package mpnotset_4dvar mp_physics_4dvar==-1 - g_moist:g_qv;a_moist:a_qv package passiveqv_4dvar mp_physics_4dvar==0 - g_moist:g_qv;a_moist:a_qv @@ -623,11 +624,8 @@ package cammgmp_4dvar mp_physics_4dvar==11 - g_moist:g_q package sbu_ylin_4dvar mp_physics_4dvar==13 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm5_4dvar mp_physics_4dvar==14 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm6_4dvar mp_physics_4dvar==16 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2mom_4dvar mp_physics_4dvar==17 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_2momccn_4dvar mp_physics_4dvar==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1mom_4dvar mp_physics_4dvar==19 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1momlfo_4dvar mp_physics_4dvar==21 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2momg_4dvar mp_physics_4dvar==22 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom_4dvar mp_physics_4dvar==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh package thompsonaero_4dvar mp_physics_4dvar==28 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package p3_1category_4dvar mp_physics_4dvar==50 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_1category_nc_4dvar mp_physics_4dvar==51 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi diff --git a/Registry/registry.wrfplus b/Registry/registry.wrfplus index 7f277a882d..2b6f933c47 100644 --- a/Registry/registry.wrfplus +++ b/Registry/registry.wrfplus @@ -872,11 +872,7 @@ package cammgmp_plus mp_physics_plus==11 - g_moist:g_qv, package sbu_ylin_plus mp_physics_plus==13 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm5_plus mp_physics_plus==14 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm6_plus mp_physics_plus==16 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2mom_plus mp_physics_plus==17 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_2momccn_plus mp_physics_plus==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1mom_plus mp_physics_plus==19 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1momlfo_plus mp_physics_plus==21 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2momg_plus mp_physics_plus==22 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg +package nssl_2mom_plus mp_physics_plus==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh package thompsonaero_plus mp_physics_plus==28 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package p3_1category_plus mp_physics_plus==50 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_1category_nc_plus mp_physics_plus==51 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi diff --git a/arch/postamble b/arch/postamble index 936f0405c8..aa55662073 100644 --- a/arch/postamble +++ b/arch/postamble @@ -203,6 +203,13 @@ wrfio_esmf : fi $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 +.F90.o: + $(RM) $@ + sed -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F90 > $*.G + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.G > $*.bb + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 + $(RM) $*.G $*.bb + $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 .F.f90: $(RM) $@ @@ -211,6 +218,13 @@ wrfio_esmf : $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.H > $@ $(RM) $*.G $*.H +.F90.f90: + $(RM) $@ + sed -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F90 > $*.G + $(SED_FTN) $*.G > $*.H + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.H > $@ + $(RM) $*.G $*.H + .f90.o: $(RM) $@ $(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 diff --git a/arch/preamble b/arch/preamble index 4543411e6f..4ae897d496 100644 --- a/arch/preamble +++ b/arch/preamble @@ -17,7 +17,7 @@ SHELL = /bin/sh DEVTOP = `pwd` LIBINCLUDE = . -.SUFFIXES: .F .i .o .f90 .c +.SUFFIXES: .F .i .o .f90 .c .F90 #### Get core settings from environment (set in compile script) #### Note to add a core, this has to be added to. diff --git a/chem/chem_driver.F b/chem/chem_driver.F index 4c8268df1b..8650b9444a 100755 --- a/chem/chem_driver.F +++ b/chem/chem_driver.F @@ -282,6 +282,8 @@ end SUBROUTINE sum_pm_driver CHARACTER (LEN=1000) :: msg CHARACTER (LEN=256) :: current_date_char integer :: current_month +!for the online nh3-"WRF-NH3-CHEM" modified by renchuanhua + integer :: current_hour ! .. ! .. Intrinsic Functions .. INTRINSIC max, min @@ -878,9 +880,14 @@ end SUBROUTINE sum_pm_driver grid%biomt_par,grid%emit_par,grid%ebio_co2oce, & eghg_bio, & grid%seas_flux, & + ! stuff for the online nh3-"WRF-NH3-CHEM" modified by renchuanhua + grid%actnh3, grid%EFnh3, & + grid%agrisoil_nh3, grid%fertilizer_nh3, grid%freeinten_nh3, & + grid%graze_nh3, grid%industry_nh3, & + grid%residential_nh3, grid%transport_nh3, current_hour, grid%Q2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) + its,ite,jts,jte,kts,kte ) if( chm_is_mozart ) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & diff --git a/chem/chemics_init.F b/chem/chemics_init.F index 59f0546883..9856ba9dc5 100755 --- a/chem/chemics_init.F +++ b/chem/chemics_init.F @@ -37,6 +37,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_mozcart_wetscav, only : wetscav_mozcart_init USE module_aerosols_sorgam USE module_aerosols_soa_vbs, only: aerosols_soa_vbs_init + USE module_aerosols_soa_vbs_het, only: aerosols_soa_vbs_het_init USE module_aerosols_sorgam_vbs, only: aerosols_sorgam_vbs_init USE module_dep_simple USE module_data_gocart_dust @@ -65,7 +66,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_ctrans_grell, only: conv_tr_wetscav_init !!! TUCCELLA (BUG) - USE module_prep_wetscav_sorgam, only: aerosols_sorgam_init_aercld_ptrs, aerosols_soa_vbs_init_aercld_ptrs + USE module_prep_wetscav_sorgam, only: aerosols_sorgam_init_aercld_ptrs, aerosols_soa_vbs_init_aercld_ptrs !!CYY USE module_model_constants, only:t0 @@ -120,7 +121,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, z_at_w,t,p,alt,convfac REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , & INTENT(INOUT ) :: & - chem + chem REAL, DIMENSION( ims:ime , 1:kemit , jms:jme, num_emis_ant ) , & INTENT(INOUT ) :: & emis_ant @@ -137,7 +138,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, integer, intent(out) :: stepbioe,stepphot,stepchem,stepfirepl TYPE (grid_config_rec_type) , INTENT (in) :: config_flags TYPE(domain) , INTENT (inout) :: grid - + REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: si_zsigf, si_zsig ! @@ -169,7 +170,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, numgas = get_last_gas(config_flags%chem_opt) numgas_out = numgas - + chem_select: SELECT CASE(config_flags%chem_opt) CASE (GOCART_SIMPLE) CALL wrf_debug(15,'calling only gocart aerosols driver from chem_driver') @@ -337,8 +338,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 109 or 503 or 504 or 601 or 611 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & - .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then - call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 17/18/22 NSSL_2mom to function.") + .and. .not. ( config_flags%mp_physics == 18 .and. config_flags%nssl_2moment_on == 1 ) ) then + call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 18 NSSL_2mom to function.") endif elseif( id == 1 ) then if ( config_flags%mp_physics /= 6 .and. config_flags%mp_physics /= 8 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 17 & @@ -375,8 +376,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, !BSINGH - kfcup schme only works with Mosaic aqueoue packages: ! *** NOTE *** ! KFCUP should in theory work with any chem_opt package that uses MOSAIC and has cloud-borne aerosols (*_aq*). - ! However, it was only tested with chem_opt=203 (saprc99_mosaic_8bin_vbs2_aq_kpp) - ! during implementation into WRF-Chem in April 2017 at PNNL. + ! However, it was only tested with chem_opt=203 (saprc99_mosaic_8bin_vbs2_aq_kpp) + ! during implementation into WRF-Chem in April 2017 at PNNL. if ( config_flags%cu_physics == 10) then if( config_flags%chem_opt /= 9 .and. config_flags%chem_opt /= 10 .and. & config_flags%chem_opt /= 32 .and. config_flags%chem_opt /= 34 .and. & @@ -426,6 +427,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal( trim(message_txt) ) endif + ! osipov check that ddflx & ddlen has correct dim size (chem_opt=106 and such) + if ( config_flags%diagnostic_dep .EQ. 1 .AND. config_flags%ne_area .LT. num_chem ) then + write(message_txt,'(''ERROR: SORGAM diagnostic_dep 1 requires ne_area('',i6,'') >= num_chem('',i6,'')'')') config_flags%ne_area,num_chem + call wrf_error_fatal( trim(message_txt) ) + endif + IF ( config_flags%chem_opt == 0 .AND. config_flags%aer_ra_feedback .NE. 0 ) THEN ! config_flags%aer_ra_feedback = 0 call wrf_error_fatal(" ERROR: CHEM_INIT: FOR CHEM_OPT = 0, AER_RA_FEEDBACK MUST = 0 ") @@ -449,7 +456,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal(" ERROR: CHEM_INIT: MUST HAVE AEROSOLS TO INCLUDE AEROSOL RADIATION FEEDBACK. SET AER_RA_FEEDBACK = 0 ") ENDIF - if ( config_flags%n2o5_hetchem == 1 )then + if ( config_flags%n2o5_hetchem == 1 )then if( (config_flags%chem_opt >= 7 .AND. config_flags%chem_opt <= 10) .OR. & (config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 34) .OR. & config_flags%chem_opt == 170 .OR. config_flags%chem_opt == 198 .OR. & @@ -488,7 +495,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ENDIF ENDIF !-- - + !-- Load dgnum arrays when restart is active IF ( config_flags%restart ) THEN do j=jts,jte @@ -497,7 +504,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, dgnum4d(i, k, j, 1) = dgnum_a1(i, k, j) dgnum4d(i, k, j, 2) = dgnum_a2(i, k, j) dgnum4d(i, k, j, 3) = dgnum_a3(i, k, j) - + dgnumwet4d(i, k, j, 1) = dgnumwet_a1(i, k, j) dgnumwet4d(i, k, j, 2) = dgnumwet_a2(i, k, j) dgnumwet4d(i, k, j, 3) = dgnumwet_a3(i, k, j) @@ -718,7 +725,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, do j=jts,jte do k=kts,kte do i=its,ite - chem(i,k,j,p_co2)=400. + chem(i,k,j,p_co2)=400. chem(i,k,j,p_ch4)=1.7 chem(i,k,j,p_ete)=chem(i,k,j,p_olt) chem(i,k,j,p_ete)=epsilc @@ -802,7 +809,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo enddo - endif + endif CASE (MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) grid%vbs_nbin=0 if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then @@ -921,7 +928,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_smpa_a02.gt.1) chem(i,k,j,p_smpa_a02)=1.e-16 if (p_smpa_a03.gt.1) chem(i,k,j,p_smpa_a03)=1.e-16 if (p_smpa_a04.gt.1) chem(i,k,j,p_smpa_a04)=1.e-16 - + if (p_smpbb_a01.gt.1) chem(i,k,j,p_smpbb_a01)=1.e-16 if (p_smpbb_a02.gt.1) chem(i,k,j,p_smpbb_a02)=1.e-16 if (p_smpbb_a03.gt.1) chem(i,k,j,p_smpbb_a03)=1.e-16 @@ -1039,7 +1046,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo endif - + !BSINGH(04/03/2014): Added 8 bin vbs non-aq pakage CASE (SAPRC99_MOSAIC_8BIN_VBS2_KPP) if(config_flags%chem_in_opt == 0 )then @@ -1144,8 +1151,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_sesq.gt.1) chem(i,k,j,p_sesq)=0.0 if (p_aro1.gt.1) chem(i,k,j,p_aro1)=0.0 if (p_aro2.gt.1) chem(i,k,j,p_aro2)=0.0 - - + + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 @@ -1164,8 +1171,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a01.gt.1) chem(i,k,j,p_biog2_o_a01)=0.0 if (p_ant3_c_a01.gt.1) chem(i,k,j,p_ant3_c_a01)=0.0 if (p_ant4_c_a01.gt.1) chem(i,k,j,p_ant4_c_a01)=0.0 - - + + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 @@ -1184,9 +1191,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a02.gt.1) chem(i,k,j,p_biog2_o_a02)=0.0 if (p_ant3_c_a02.gt.1) chem(i,k,j,p_ant3_c_a02)=0.0 if (p_ant4_c_a02.gt.1) chem(i,k,j,p_ant4_c_a02)=0.0 - - - + + + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 @@ -1205,8 +1212,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a03.gt.1) chem(i,k,j,p_biog2_o_a03)=0.0 if (p_ant3_c_a03.gt.1) chem(i,k,j,p_ant3_c_a03)=0.0 if (p_ant4_c_a03.gt.1) chem(i,k,j,p_ant4_c_a03)=0.0 - - + + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 @@ -1225,8 +1232,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a04.gt.1) chem(i,k,j,p_biog2_o_a04)=0.0 if (p_ant3_c_a04.gt.1) chem(i,k,j,p_ant3_c_a04)=0.0 if (p_ant4_c_a04.gt.1) chem(i,k,j,p_ant4_c_a04)=0.0 - - + + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 @@ -1245,8 +1252,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a05.gt.1) chem(i,k,j,p_biog2_o_a05)=0.0 if (p_ant3_c_a05.gt.1) chem(i,k,j,p_ant3_c_a05)=0.0 if (p_ant4_c_a05.gt.1) chem(i,k,j,p_ant4_c_a05)=0.0 - - + + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 @@ -1265,8 +1272,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a06.gt.1) chem(i,k,j,p_biog2_o_a06)=0.0 if (p_ant3_c_a06.gt.1) chem(i,k,j,p_ant3_c_a06)=0.0 if (p_ant4_c_a06.gt.1) chem(i,k,j,p_ant4_c_a06)=0.0 - - + + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 @@ -1285,8 +1292,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a07.gt.1) chem(i,k,j,p_biog2_o_a07)=0.0 if (p_ant3_c_a07.gt.1) chem(i,k,j,p_ant3_c_a07)=0.0 if (p_ant4_c_a07.gt.1) chem(i,k,j,p_ant4_c_a07)=0.0 - - + + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 @@ -1305,19 +1312,19 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a08.gt.1) chem(i,k,j,p_biog2_o_a08)=0.0 if (p_ant3_c_a08.gt.1) chem(i,k,j,p_ant3_c_a08)=0.0 if (p_ant4_c_a08.gt.1) chem(i,k,j,p_ant4_c_a08)=0.0 - - - + + + enddo enddo enddo endif !BSINGH(04/03/2014):ENDS - - - !BSINGH(12/03/2013) - Added case statement for SAPRC 8 bin + + + !BSINGH(12/03/2013) - Added case statement for SAPRC 8 bin CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP )!BSINGH (12/11/13): Got rid of SAPRC99_MOSAIC_4BIN_VBS2_AQ_KPP and SAPRC99_MOSAIC_4BIN_VBS2_KPP - + if(config_flags%chem_in_opt == 1 ) grid%vbs_nbin=2 if(config_flags%chem_in_opt == 0 )then grid%vbs_nbin=2 @@ -1410,7 +1417,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o.gt.1) chem(i,k,j,p_biog2_o)=0.0 if (p_biog3_o.gt.1) chem(i,k,j,p_biog3_o)=0.0 if (p_biog4_o.gt.1) chem(i,k,j,p_biog4_o)=0.0 - + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 @@ -1421,7 +1428,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a01.gt.1) chem(i,k,j,p_opcg1_f_o_a01)=0.0 if (p_ant1_c_a01.gt.1) chem(i,k,j,p_ant1_c_a01)=0.0 if (p_biog1_c_a01.gt.1) chem(i,k,j,p_biog1_c_a01)=0.0 - + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 @@ -1432,7 +1439,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a02.gt.1) chem(i,k,j,p_opcg1_f_o_a02)=0.0 if (p_ant1_c_a02.gt.1) chem(i,k,j,p_ant1_c_a02)=0.0 if (p_biog1_c_a02.gt.1) chem(i,k,j,p_biog1_c_a02)=0.0 - + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 @@ -1443,7 +1450,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a03.gt.1) chem(i,k,j,p_opcg1_f_o_a03)=0.0 if (p_ant1_c_a03.gt.1) chem(i,k,j,p_ant1_c_a03)=0.0 if (p_biog1_c_a03.gt.1) chem(i,k,j,p_biog1_c_a03)=0.0 - + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 @@ -1454,7 +1461,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a04.gt.1) chem(i,k,j,p_opcg1_f_o_a04)=0.0 if (p_ant1_c_a04.gt.1) chem(i,k,j,p_ant1_c_a04)=0.0 if (p_biog1_c_a04.gt.1) chem(i,k,j,p_biog1_c_a04)=0.0 - + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 @@ -1465,7 +1472,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a05.gt.1) chem(i,k,j,p_opcg1_f_o_a05)=0.0 if (p_ant1_c_a05.gt.1) chem(i,k,j,p_ant1_c_a05)=0.0 if (p_biog1_c_a05.gt.1) chem(i,k,j,p_biog1_c_a05)=0.0 - + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 @@ -1476,7 +1483,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a06.gt.1) chem(i,k,j,p_opcg1_f_o_a06)=0.0 if (p_ant1_c_a06.gt.1) chem(i,k,j,p_ant1_c_a06)=0.0 if (p_biog1_c_a06.gt.1) chem(i,k,j,p_biog1_c_a06)=0.0 - + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 @@ -1487,7 +1494,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a07.gt.1) chem(i,k,j,p_opcg1_f_o_a07)=0.0 if (p_ant1_c_a07.gt.1) chem(i,k,j,p_ant1_c_a07)=0.0 if (p_biog1_c_a07.gt.1) chem(i,k,j,p_biog1_c_a07)=0.0 - + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 @@ -1498,9 +1505,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a08.gt.1) chem(i,k,j,p_opcg1_f_o_a08)=0.0 if (p_ant1_c_a08.gt.1) chem(i,k,j,p_ant1_c_a08)=0.0 if (p_biog1_c_a08.gt.1) chem(i,k,j,p_biog1_c_a08)=0.0 - - - + + + if (p_pcg1_b_c_cw01.gt.1) chem(i,k,j,p_pcg1_b_c_cw01)=0.0 if (p_pcg1_b_o_cw01.gt.1) chem(i,k,j,p_pcg1_b_o_cw01)=0.0 if (p_opcg1_b_c_cw01.gt.1) chem(i,k,j,p_opcg1_b_c_cw01)=0.0 @@ -1511,7 +1518,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw01.gt.1) chem(i,k,j,p_opcg1_f_o_cw01)=0.0 if (p_ant1_c_cw01.gt.1) chem(i,k,j,p_ant1_c_cw01)=0.0 if (p_biog1_c_cw01.gt.1) chem(i,k,j,p_biog1_c_cw01)=0.0 - + if (p_pcg1_b_c_cw02.gt.1) chem(i,k,j,p_pcg1_b_c_cw02)=0.0 if (p_pcg1_b_o_cw02.gt.1) chem(i,k,j,p_pcg1_b_o_cw02)=0.0 if (p_opcg1_b_c_cw02.gt.1) chem(i,k,j,p_opcg1_b_c_cw02)=0.0 @@ -1522,7 +1529,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw02.gt.1) chem(i,k,j,p_opcg1_f_o_cw02)=0.0 if (p_ant1_c_cw02.gt.1) chem(i,k,j,p_ant1_c_cw02)=0.0 if (p_biog1_c_cw02.gt.1) chem(i,k,j,p_biog1_c_cw02)=0.0 - + if (p_pcg1_b_c_cw03.gt.1) chem(i,k,j,p_pcg1_b_c_cw03)=0.0 if (p_pcg1_b_o_cw03.gt.1) chem(i,k,j,p_pcg1_b_o_cw03)=0.0 if (p_opcg1_b_c_cw03.gt.1) chem(i,k,j,p_opcg1_b_c_cw03)=0.0 @@ -1533,7 +1540,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw03.gt.1) chem(i,k,j,p_opcg1_f_o_cw03)=0.0 if (p_ant1_c_cw03.gt.1) chem(i,k,j,p_ant1_c_cw03)=0.0 if (p_biog1_c_cw03.gt.1) chem(i,k,j,p_biog1_c_cw03)=0.0 - + if (p_pcg1_b_c_cw04.gt.1) chem(i,k,j,p_pcg1_b_c_cw04)=0.0 if (p_pcg1_b_o_cw04.gt.1) chem(i,k,j,p_pcg1_b_o_cw04)=0.0 if (p_opcg1_b_c_cw04.gt.1) chem(i,k,j,p_opcg1_b_c_cw04)=0.0 @@ -1544,7 +1551,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw04.gt.1) chem(i,k,j,p_opcg1_f_o_cw04)=0.0 if (p_ant1_c_cw04.gt.1) chem(i,k,j,p_ant1_c_cw04)=0.0 if (p_biog1_c_cw04.gt.1) chem(i,k,j,p_biog1_c_cw04)=0.0 - + if (p_pcg1_b_c_cw05.gt.1) chem(i,k,j,p_pcg1_b_c_cw05)=0.0 if (p_pcg1_b_o_cw05.gt.1) chem(i,k,j,p_pcg1_b_o_cw05)=0.0 if (p_opcg1_b_c_cw05.gt.1) chem(i,k,j,p_opcg1_b_c_cw05)=0.0 @@ -1555,7 +1562,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw05.gt.1) chem(i,k,j,p_opcg1_f_o_cw05)=0.0 if (p_ant1_c_cw05.gt.1) chem(i,k,j,p_ant1_c_cw05)=0.0 if (p_biog1_c_cw05.gt.1) chem(i,k,j,p_biog1_c_cw05)=0.0 - + if (p_pcg1_b_c_cw06.gt.1) chem(i,k,j,p_pcg1_b_c_cw06)=0.0 if (p_pcg1_b_o_cw06.gt.1) chem(i,k,j,p_pcg1_b_o_cw06)=0.0 if (p_opcg1_b_c_cw06.gt.1) chem(i,k,j,p_opcg1_b_c_cw06)=0.0 @@ -1566,7 +1573,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw06.gt.1) chem(i,k,j,p_opcg1_f_o_cw06)=0.0 if (p_ant1_c_cw06.gt.1) chem(i,k,j,p_ant1_c_cw06)=0.0 if (p_biog1_c_cw06.gt.1) chem(i,k,j,p_biog1_c_cw06)=0.0 - + if (p_pcg1_b_c_cw07.gt.1) chem(i,k,j,p_pcg1_b_c_cw07)=0.0 if (p_pcg1_b_o_cw07.gt.1) chem(i,k,j,p_pcg1_b_o_cw07)=0.0 if (p_opcg1_b_c_cw07.gt.1) chem(i,k,j,p_opcg1_b_c_cw07)=0.0 @@ -1577,7 +1584,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw07.gt.1) chem(i,k,j,p_opcg1_f_o_cw07)=0.0 if (p_ant1_c_cw07.gt.1) chem(i,k,j,p_ant1_c_cw07)=0.0 if (p_biog1_c_cw07.gt.1) chem(i,k,j,p_biog1_c_cw07)=0.0 - + if (p_pcg1_b_c_cw08.gt.1) chem(i,k,j,p_pcg1_b_c_cw08)=0.0 if (p_pcg1_b_o_cw08.gt.1) chem(i,k,j,p_pcg1_b_o_cw08)=0.0 if (p_opcg1_b_c_cw08.gt.1) chem(i,k,j,p_opcg1_b_c_cw08)=0.0 @@ -1611,7 +1618,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ids,ide,jds,jde,kds,kde,its,ite,jts,jte,kts,kte) ENDIF - + !! Initialize some greenhouse gas species for 16th and 17th chemistry options: !! CO2 mixing ratios for the background GHG tracers are set as a constant value. !! Some spin-up is necessary to get spatial variability right! @@ -1776,7 +1783,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, gmtp=mod(xhour,24.) gmtp=gmtp+xmin/60. CALL szangle(1, 1, julday, gmtp, sza, cosszax,xlonn,rlat) - TCOSZ(i,j)=TCOSZ(I,J)+cosszax(1,1) + TCOSZ(i,j)=TCOSZ(I,J)+cosszax(1,1) if(cosszax(1,1).gt.0.)ttday(i,j)=ttday(i,j)+dt enddo ! if(i.eq.19.and.j.eq.19)write(0,*)'in cheminit' @@ -1847,7 +1854,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) - CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP,RACM_SOA_VBS_HET_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') call aerosols_soa_vbs_init(chem,convfac,z_at_w, & @@ -1859,8 +1866,37 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, !!!TUCCELLA (BUG, before it was called in module_aerosols_soa_vbs.F) ! initialize pointers used by aerosol-cloud-interaction routines - call aerosols_soa_vbs_init_aercld_ptrs( & - num_chem, is_aerosol, config_flags ) + call aerosols_soa_vbs_init_aercld_ptrs(num_chem, is_aerosol, config_flags ) + +!...Convert aerosols to mixing ratio + if( .NOT. config_flags%restart ) then + if(config_flags%chem_in_opt == 0 .and. num_chem.gt.numgas)then + do l=numgas+1,num_chem + do j=jts,jte + do k=kts,kte + kk = min(k,kde-1) + do i=its,ite + chem(i,k,j,l)=chem(i,kk,j,l)*alt(i,kk,j) + enddo + enddo + enddo + enddo + endif + endif + chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) + CASE (RACM_SOA_VBS_HET_KPP) + CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') + + call aerosols_soa_vbs_het_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + chem_in_opt,config_flags%aer_ic_opt,is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, config_flags ) + +!!!TUCCELLA (BUG, before it was called in module_aerosols_soa_vbs.F) + ! initialize pointers used by aerosol-cloud-interaction routines + call aerosols_soa_vbs_init_aercld_ptrs(num_chem, is_aerosol, config_flags ) !...Convert aerosols to mixing ratio if( .NOT. config_flags%restart ) then diff --git a/chem/emissions_driver.F b/chem/emissions_driver.F index 9c4c8cb1a8..47b1e6f4b2 100644 --- a/chem/emissions_driver.F +++ b/chem/emissions_driver.F @@ -70,10 +70,15 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ! stuff for aircraft emissions emis_aircraft, & ! stuff for GHG fluxes - vprm_in,rad_vprm,lambda_vprm,alpha_vprm,resp_vprm, & + vprm_in,rad_vprm,lambda_vprm,alpha_vprm,resp_vprm, & xtime,tslb,wet_in,rainc,rainnc,potevp,sfcevp,lu_index, & biomt_par,emit_par,ebio_co2oce,eghg_bio, & seas_flux, & + ! stuff for online nh3 "WRF-NH3-CHEM" modified by renchuanhua + actnh3,EFnh3, & + agrisoil_nh3, fertilizer_nh3, freeinten_nh3, graze_nh3, & + industry_nh3, residential_nh3, & + transport_nh3, current_hour, Q2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -131,7 +136,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & REAL, DIMENSION( ims:ime, jms:jme, ne_area ), & INTENT(INOUT ) :: e_bio REAL, DIMENSION( ims:ime, 1:config_flags%kemit, jms:jme,num_emis_ant),& - INTENT(IN ) :: & + INTENT(INOUT ) :: & emis_ant REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_emis_vol), & INTENT(INOUT ) :: & @@ -290,7 +295,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & real, dimension (ims:ime, jms:jme ) , & intent(in) :: & - T2, swdown + T2, swdown, Q2 ! modifed by renchuanhua integer, intent(in) :: current_month @@ -336,7 +341,53 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ht, ic_flashrate, cg_flashrate REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: refl_10cm ! end stuff for lightning NOx -! + +! stuff for online NH3 "WRF-NH3-CHEM" modified by renchuanhua + REAL, DIMENSION( ims:ime,12,jms:jme ), OPTIONAL, INTENT(IN ) :: actnh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: EFnh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: agrisoil_nh3 + REAL, DIMENSION( ims:ime,12,jms:jme ), OPTIONAL, INTENT(INOUT ) :: fertilizer_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: freeinten_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: graze_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: industry_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: residential_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: transport_nh3 + INTEGER, INTENT(IN ) :: current_hour + + + ! local variables + real,parameter :: EFstd =5.5 + real :: CFwind,CFtemp,CFsmois_hus,CFrain + integer :: h + real, dimension (ims:ime, jms:jme ) :: frin_house, frin_sManure,frin_manureStore !renchuanhua + real, dimension (ims:ime, jms:jme ) :: graze_house, graze_out + real, dimension (ims:ime, jms:jme ) :: CFsmois + real, dimension (ims:ime, jms:jme ) :: T_house, V_house, GF_Thouse + real, parameter :: Factor_fihouse=0.156, Factor_sManure=0.774, Factor_manureStore=0.07 + real, parameter :: Factor_grhouse=0.226 + + real, dimension (ims:ime, jms:jme ) :: house, store ,outsoil + real, dimension (ims:ime, jms:jme ) :: emis_house, emis_store ,emis_fert + +real, save :: freq_residential(24) = & + (/0.0110, 0.0030, 0.0010, 0.0000, 0.0020, 0.0169, & + 0.0914, 0.2111, 0.1402, 0.0905, 0.0676, 0.0487, & + 0.0179, 0.0358, 0.0258, 0.0182, 0.0272, 0.0222, & + 0.0411, 0.0401, 0.0268, 0.0202, 0.0212, 0.0202/) +real, save :: freq_transport(24) = & + (/0.02, 0.01, 0.01, 0.00, 0.00, 0.00, & + 0.01, 0.03, 0.06, 0.06, 0.06, 0.05, & + 0.06, 0.06, 0.06, 0.07, 0.07, 0.08, & + 0.08, 0.07, 0.05, 0.04, 0.03, 0.02/) +real, save :: freq_industry(24) = & + (/0.02, 0.01, 0.01, 0.00, 0.00, 0.00, & + 0.01, 0.03, 0.06, 0.06, 0.06, 0.05, & + 0.06, 0.06, 0.06, 0.07, 0.07, 0.08, & + 0.08, 0.07, 0.05, 0.04, 0.03, 0.02/) + +! end stuff online NH3 + + ! Local variables... ! INTEGER :: begday,endday,i, j, k, m, p_in_chem, ksub, dust_emiss_active, seasalt_emiss_active,emiss_ash_hgt @@ -951,6 +1002,76 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & END SELECT bioem_select !!! **************** END BIOGENICS, ADD EMISSIONS FOR VARIOUS PACKAGES + + +!!! online nh3 "WRF-NH3-CHEM" modified by renchuanhua + + if( config_flags%nh3emis_opt == ONLINE) then + emis_ant(ims:ime , config_flags%kemit , jms:jme, p_e_nh3)=0.0 + + frin_house = freeinten_nh3*Factor_fihouse ! house [in] + frin_sManure = freeinten_nh3*Factor_sManure ! manure - field [out] + frin_manureStore = freeinten_nh3*Factor_manureStore ! manure - store [none] + graze_house = graze_nh3*Factor_grhouse ! graze [in] + graze_out = graze_nh3*(1.0-Factor_grhouse) ! graze [out] + + GF_Thouse =1.0 + +! Animal house temperature and wind speed + where( T2.LT.273.15) + T_house = 287.15 + 0.5*(T2-(273.15+0)) + V_house = 0.2 + elsewhere(T2 .GE. 273.15 .and. T2 .LT. 285.65) + T_house = 287.15 + V_house = 0.2 + T2*(0.405/12.5) + elsewhere(T2 .GE. 285.65) + T_house = 287.15 + 1.4*(T2-(285.65)) + V_house = 0.405 !0.5*(0.38+0.43) + end where + +! out field soil moisture correction factor + where( smois(:,1,:).LT.0.45) + CFsmois = 0.45*exp(-1.0*smois(:,1,:))+0.55 + elsewhere(smois(:,1,:).GE.0.45) + CFsmois = 0.45*exp(smois(:,1,:))+0.6 + end where + + + do j=jts,jte + do i=its,ite + + + CFwind =exp(0.0419*(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))**0.5) + CFtemp = (exp(0.093*(tsk(i,j)-T2(i,j))-0.57))*exp(0.018*(tsk(i,j)-273.15)) + CFrain = 1/(3.2*rainnc(i,j)+1.0) + EFnh3(i,j)=CFsmois(i,j)*CFtemp*CFrain*CFwind + + CFsmois_hus = 0.45*exp(-1.0*smois(i,1,j))+0.55 + GF_Thouse =exp((0.093*(T_house(i,j)-tsk(i,j)))-0.57)*exp(0.018*(tsk(i,j)-273.15)) + + ! for house + emis_house(i,j) = CFsmois_hus*GF_Thouse(i,j)*exp(0.0419*V_house(i,j))*(frin_house(i,j) + graze_house(i,j)) + ! for store + emis_store(i,j) = frin_manureStore(i,j) + ! for outside soil + emis_fert(i,j) = EFnh3(i,j)*(fertilizer_nh3(i,current_month,j)+frin_sManure(i,j)+ graze_out(i,j)+agrisoil_nh3(i,j)) + + +! fertilizer and freeinten .... units is kg/km2/month +! conv is used to change units from "mole/km2/hr" to "delta ppmv" + conv = 4.828e-4/rho_phy(i,1,j)*dtstep/(dz8w(i,1,j)*60.) + h=MOD(current_hour+8,24) !range 0-23 + + emis_ant(i,1,j,p_e_nh3)=1000.0/(17.0*30.0*24.0)*(emis_house(i,j)+emis_store(i,j)+emis_fert(i,j)) & + + freq_residential(h+1)*residential_nh3(i,j)*1000.0/(30.0*17.0) & + + freq_industry(h+1) *industry_nh3(i,j)*1000.0/(30.0*17.0) & + + freq_transport(h+1) *transport_nh3(i,j)*1000.0/(30.0*17.0) + enddo + enddo + + end if + + ! gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & diff --git a/chem/module_aerosols_soa_vbs_het.F b/chem/module_aerosols_soa_vbs_het.F index ca7c90059e..5a3e0d2019 100644 --- a/chem/module_aerosols_soa_vbs_het.F +++ b/chem/module_aerosols_soa_vbs_het.F @@ -6593,7 +6593,7 @@ SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, & END SUBROUTINE VDVG_2 !------------------------------------------------------------------------------ -SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, & +SUBROUTINE aerosols_soa_vbs_het_init(chem,convfac,z_at_w, & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & chem_in_opt,aer_ic_opt, is_aerosol, & ids,ide, jds,jde, kds,kde, & @@ -6812,7 +6812,7 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, ! chem, zz, i,k,j, ims,ime,jms,jme,kms,kme ) else call wrf_error_fatal( & - "aerosols_soa_vbs_init: unable to parse aer_ic_opt" ) + "aerosols_soa_vbs_het_init: unable to parse aer_ic_opt" ) end if !... i-mode @@ -6861,7 +6861,7 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, enddo return - END SUBROUTINE aerosols_soa_vbs_init + END SUBROUTINE aerosols_soa_vbs_het_init ! SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & diff --git a/clean b/clean index 6ce8142cd6..2fd6453194 100755 --- a/clean +++ b/clean @@ -3,12 +3,12 @@ set nonomatch -foreach dir ( frame chem share dyn_em phys cmaq main tools wrftladj ) +foreach dir ( frame chem share dyn_em phys phys/physics_mmm cmaq main tools wrftladj ) if ( -d $dir ) then if ( $dir == cmaq ) then ( cd $dir ; echo $dir ; /bin/rm -f *.o *.mod ) >& /dev/null else - ( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.obj *.inc *.F90 *.a \ + ( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.obj *.inc *.a \ db_* Warnings module_state_description.F module_dm.F gmeta \ wrfdata whatiread rsl.* show_domain* ) >& /dev/null endif diff --git a/configure b/configure index 41243e2813..5e2bedb10f 100755 --- a/configure +++ b/configure @@ -59,7 +59,7 @@ if `pwd | grep ' ' > /dev/null ` ; then echo and this may cause problems for your build. This can occur, for example, on echo Windows systems. It is strongly recommended that you install WRF and other echo related software such as NetCDF in directories whose path names contain no - echo white space. On Win, for example, create and install in a directory under C:. + echo white space. On Windows, for example, create and install in a directory under C:. echo '*****************************************************************************' fi @@ -219,6 +219,8 @@ if [ -n "$NETCDFPAR" ] ; then export NETCDF export NETCDF4 export USENETCDFPAR +else + export USENETCDFPAR=0 fi if test -z "$NETCDF" ; then @@ -657,7 +659,7 @@ fi #Checking cross-compiling capability for some particular environment #on Linux and Mac box -if [ $os = "Linux" -o $os = "Darwin" ]; then +if [ $os = "Linux" -o $os = "Darwin" -o $os = "CYGWIN_NT" ]; then SFC=`grep '^SFC' configure.wrf | awk '{print $3}'` SCC=`grep '^SCC' configure.wrf | awk '{print $3}'` diff --git a/doc/README.NSSLmp b/doc/README.NSSLmp new file mode 100644 index 0000000000..e9b673653e --- /dev/null +++ b/doc/README.NSSLmp @@ -0,0 +1,165 @@ +Some background information and usage tips for the NSSL microphysics scheme. + + + IMPORTANT: Best results are attained using WENO (Weighted Essentially Non-Oscillatory) scalar advection option. This helps to limit oscillations at the edges of precipitation regions (i.e., sharp gradient), which in turns helps to prevent mismatches of moments that can show up as noisy reflectivity values. + moist_adv_opt = 4, + scalar_adv_opt = 3, + The monotonic option (2) is less effective, but better than the default positive definite option (1) + +NOTE TO SMPAR or DM+SMPAR USERS: If a segmentation fault occurs, try setting the environment variable OMP_STACKSIZE to 8M or 16M (default is 4M, where M=MB). Note that this does not increase the shell stacksize limit [use 'ulimit -a unlimited' (bash) or 'unlimit stacksize' (tcsh)] + +CHANGES: +June 2023 (WRF 4.6): Main default option change is for graupel/hail fall speed options (icdx, icdxhl; changed from 3 to 6, see below), and default maximum gr/hail droplet collection efficiencies (ehw0/ehlw0 changed from 0.5/0.75 to 0.9/0.9, see below). Snow aggregation efficiency is reduced to limit excessive snow reflectivity (see below). + +CONTACT: For questions not covered here (or other issues/bugs), feel free to contact Ted Mansell (NOAA/NSSL) at ted.mansell_at_noaa.gov and/or tag @MicroTed in a github issue. + +DESCRIPTION: + +The NSSL bulk microphysical parameterization scheme describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) and Mansell and Ziegler (2013). It is designed with deep (severe) convection in mind at grid spacings of up to 4 km, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. The scheme predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. The 3-moment option additionally predicts the 6th moments of rain, graupel, and hail which in turn predicts the PSD shape parameters (set nssl_3moment=.true.). + +Basic options in physics namelist: + mp_physics = 18 ! NSSL scheme (2-moment) with hail and predicted + CCN concentration + options + + The legacy options (17,19,21,22) still behave as before (for now), but going + forward one should use mp_physics=18 with modifier flags: + + mp_physics + = 22 ! NSSL scheme (2-moment) without hail + Equivalent: mp=18, nssl_hail_on=0, nssl_ccn_on=0 + = 17 ! NSSL scheme (2-moment) with hail with constant background CCN + concentration + Equivalent: mp=18, nssl_ccn_on=0 + = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) + Equivalent: mp=18, nssl_2moment_on=0, nssl_ccn_on=0 (do no set nssl_hail_on) + = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 + Equivalent: mp=18, nssl_2moment_on=0, nssl_hail_on=0, nssl_ccn_on=0, + nssl_density_on=0 + +Option flags (integer; apply to all domains except nssl_hail_on): + + nssl_3moment : default value of 0, setting to 1 adds 6th moment for rain, + graupel (i.e., 3-moment ) and hail (Only needed for turning + 3-moment on) + + nssl_density_on : default value of 1; Setting to 0 turns off graupel/hail predicted + ice density and instead uses fixed (constant) ice density + for graupel (nssl_rho_qh, default 500.) and hail (nssl_rho_qhl, + default 800.) (Only needed for turning density off) + + nssl_ccn_on : predicted CCN concentration: default is on (1) for mp_physics=18 + + nssl_hail_on : If not set explicitly, it is set automatically to 1. This is the only + flag with dimensions of 'max_domains' e.g., so that hail can be turned + off on non-convection-allowing parent domains (Default is on, so this + is only needed for turning the hail species off) + + nssl_ccn_is_ccna : The CCN category, if enabled (=1), can be used to represent either the + number of unactivated CCN (default, value of 0, with irenuc=2), or, if + set to 1, it is CCNA (the number of activated CCN, background value + of zero). If irenuc >= 5 (see below), this is automatically set to 1. + + nssl_2moment_on : only use this flag to run single-moment (value of 0), otherwise + default is 1 (Only needed for turning 2-moment off) + + Other namelist options (also "physics" namelist) + nssl_alphah = 0. ! PSD shape parameter for graupel (1- and 2-moment) + nssl_alphahl = 1. ! PSD shape parameter for hail (1- and 2-moment) + nssl_cnoh = 4.e5 ! graupel intercept (1-moment only) + nssl_cnohl = 4.e4 ! hail intercept (1-moment only) + nssl_cnor = 8.e5 ! rain intercept (1-moment only) + nssl_cnos = 3.e6 ! snow intercept (1-moment only) + nssl_rho_qh = 500. ! graupel density (nssl_density_on=0) + nssl_rho_qhl = 800. ! hail density (nssl_density_on=0) + nssl_rho_qs = 100. ! snow density + + + nssl_cccn - (real) Initial concentration of cloud condensation + nuclei (per m^3 at sea level) + 0.25e+9 maritime + 0.5e+9 "low-med" continental (DEFAULT) + 1.0e+9 "med-high" continental + 1.5e+09 - high-extreme continental CCN) + Larger values run a risk of unrealistically weak + precipitation production + The value of nssl_cccn sets the concentration at MSL, and an initially + homogeneous number mixing ratio (ccn/1.225) is assumed throughout + the depth of the domain. The droplet concentration near cloud base + will be less than nssl_cccn because of the well-mixed assumption, + so if a target Nc is desired, set nssl_cccn higher by a factor of + 1.225/(air density at cloud base). + +The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel that is actively riming (esp. in wet growth). + +Hydrometeor size distributions are assumed to follow a gamma functional form. (Shape parameters for 2-moment graupel and hail can be set with nssl_alphah/nssl_alphahl.) Microphysical processes include cloud droplet and cloud ice nucleation, condensation, deposition, evaporation, sublimation, collection–coalescence, variable-density riming, shedding, ice multiplication, cloud ice aggregation, freezing and melting, and conversions between hydrometeor categories. + +Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. (2010) with a bulk activation spectrum approximating small aerosols. (New option nssl_ccn_is_ccna=1 instead predicts the number of activated CCN.) The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present (ccntimeconst). Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. + +Droplet activation option method is controlled by the 'irenuc' option (internal to NSSL module). The default option (2) depletes CCN from the unactivated CCN field. A new option (7) instead counts the number of activated CCN (nucleated droplets) with the assumption of an initial constant CCN number mixing ratio. Option 7 better handles supersaturation at low CCN (e.g., maritime) concentrations by allowing extra droplet activation at high SS. + + irenuc : (nssl_mp_params namelist) + 2 = ccn field is UNactivated aerosol (default; old droplet activation) + Can switch to counting activated CCN with nssl_ccn_is_ccna=1 + 7 = ccn field must be ACTVIATED aerosol (new droplet activation) + Must have nssl_ccn_on=1 for irenuc=7 + +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010). For 2-moment, infall=4 (default; nssl_mp_params namelist) is recommended. For 3-moment, infall only really applies to droplets, cloud ice, and snow. + +Graupel -> hail conversion: The parameter ihlcnh selects the method of converting graupel (hail embryos) to the hail category. The default value is -1 for automatic setting. The original option (ihlcnh=1) is replaced by a new option (ihlcnh=3) as of May 2023. ihlcnh=3 converts from the graupel spectrum itself based on the wet growth diameter, which generally results in fewer initiated hailstones with larger diameters (and larger mean diameter at the ground). If hail size seems excessive, try setting ihlcnh=1, which tends to generate higher hail number concentrations and thus smaller diameters. + +The June 2023 (WRF 4.6) update introduces changes in the default options for graupel/hail fall speeds and collection efficiencies. The original fall speed options (icdx=3; icdxhl=3) from Mansell et al. (2010) are switched to the Milbrandt and Morrison (2013) fall speed curves (icdx=6; icdxhl=6). Because the fall speeds are generally a bit lower, a partially compensating increase in maximum collection efficiency is set by default: ehw0/ehlw0 increased to 0.9. One effect is somewhat reduced total precipitation and cold pool intensity for supercell storms. + + (nssl_mp_params namelist) + icdx - fall speed option for graupel (was 3, now is 6) + icdxhl - fall speed option for hail (was 3, now is 6) + ehw0,ehlw0 - Maximim droplet collection efficiencies for graupel (ehw0=0.75, now 0.9) + and hail (ehlw0=0.75, now 0.9) + ihlcnh - graupel to hail conversion option (was 1, now 3) + +In summary, to get something closer to previous behavior, use the following: + +&nssl_mp_params + icdx = 3 + icdxhl = 3 + ehw0 = 0.5 + ehlw0 = 0.75 + ihlcnh = 1 +/ + +Snow Aggregation and reflectivity: + +Snow self-collection (aggregation) has been curbed in the 4.6 version by reducing the collision efficiency and the temperature range over which aggregation is allowed (esstem): + + ess0 = 0.5 ! collision efficiency, reduced from 1 to 0.5 + esstem1 = -15. ! was -25. ! lower temperature where snow aggregation turns on + esstem2 = -10. ! was -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + + If desired, some further reduction in aggregation can be gained from setting iessopt=4, which reduces ess0 to 0.1 (80% reduction) in conditions of ice subsaturation (RHice < 100%). + Snow reflectivity formerly had a default setting that turned on a crude bright band enhancement (iusewetsnow=1). This is now turned off by default (iusewetsnow=0) + These snow parameters can be accessed through the nssl_mp_params namelist. + +References: + +Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification + of a small thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., + 67, 171-194, doi:10. 1175/2009JAS2965.1. + +Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm + electrification and precipitation in a two-moment bulk microphysics model. + J. Atmos. Sci., 70 (7), 2032-2050, doi:10.1175/JAS-D-12-0264.1. + +Mansell, E. R., D. T. Dawson, J. M. Straka, Bin-emulating Hail Melting in 3-moment + bulk microphysics, J. Atmos. Sci., 77, 3361-3385, doi: 10.1175/JAS-D-19-0268.1 + +Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed + convective storms. Part I: Model development and preliminary testing. J. + Atmos. Sci., 42, 1487-1509. + +Sedimentation reference: + +Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. + J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. + + + + diff --git a/doc/README.cygwin.md b/doc/README.cygwin.md index 1d8599e951..3c5b45461d 100644 --- a/doc/README.cygwin.md +++ b/doc/README.cygwin.md @@ -17,11 +17,28 @@ - gcc-core (OpenMP for smpar) - gcc-fortran - libnetcdf-fortran-devel + - libnetcdf-devel + - libhdf5-devel + - zlib-devel - openmpi (MPI for dmpar) - libopenmpi-devel (MPI for dmpar) + - libhwloc-devel (MPI for dmpar) + - libevent-devel (MPI for dmpar) - libjasper-devel (GRIB) - perl + - perl_base - tcsh + - m4 + - make + - libtirpc-devel + - sed + - gawk + - tar + - gzip + - coreutils + - which + - file + - grep - Select install - Accept the packages pulled in as dependencies - Wait for download, install, and postinstall steps. This will diff --git a/doc/README.netcdf4par b/doc/README.netcdf4par index a4f50e1a07..e40edb9240 100644 --- a/doc/README.netcdf4par +++ b/doc/README.netcdf4par @@ -41,4 +41,4 @@ Performance seems to vary with how 'regular' the domain decomposition is (i.e., patch size). Some experimentation with manually setting the decomposition may be needed for optimal writing times. Also pay attention to file system striping (Lustre), where setting the number stripes should not exceed the -number of nodes used by the job. \ No newline at end of file +number of nodes used by the job. diff --git a/dyn_em/module_advect_em.F b/dyn_em/module_advect_em.F index 58145e340f..b8cf8988d6 100644 --- a/dyn_em/module_advect_em.F +++ b/dyn_em/module_advect_em.F @@ -4146,8 +4146,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -4162,8 +4162,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7297,8 +7297,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7313,8 +7313,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7330,8 +7330,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jts == jds) ) THEN ! Assuming rv(i,k,jds) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*rv(i,k,jts+1), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7347,8 +7347,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jte == jde)) THEN ! Assuming rv(i,k,jde) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*rv(i,k,jte-1), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7412,6 +7412,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7424,6 +7427,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7436,6 +7442,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7485,6 +7494,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7497,6 +7509,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7509,6 +7524,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7956,7 +7974,7 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28 + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-40 integer, parameter :: pw = 2 @@ -8652,7 +8670,7 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28 + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-40 integer, parameter :: pw = 2 diff --git a/dyn_em/module_big_step_utilities_em.F b/dyn_em/module_big_step_utilities_em.F index 50d7972c62..72e827b275 100644 --- a/dyn_em/module_big_step_utilities_em.F +++ b/dyn_em/module_big_step_utilities_em.F @@ -5105,8 +5105,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%cu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5116,8 +5116,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5126,8 +5126,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5136,8 +5136,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5146,8 +5146,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5156,8 +5156,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5169,8 +5169,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5180,8 +5180,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5190,8 +5190,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5200,8 +5200,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5210,8 +5210,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5220,8 +5220,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5230,8 +5230,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5296,8 +5296,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5312,8 +5312,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5322,8 +5322,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ! If using moist theta, get dry theta tendency for CPSs IF ( config_flags%use_theta_m == 1 ) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end th_phy(i,k,j) = (t_new(i,k,j) + t0) / (1. + (R_v/R_d) * qv(i,k,j)) rthften(i,k,j) = th_phy(i,k,j)/(t_new(i,k,j)+t0) * & (rthften(i,k,j) - (R_v/R_d) * th_phy(i,k,j) * rqvften(i,k,j)) diff --git a/dyn_em/module_em.F b/dyn_em/module_em.F index b71934b641..56df890f90 100644 --- a/dyn_em/module_em.F +++ b/dyn_em/module_em.F @@ -2208,8 +2208,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%cu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUCUTEN(I,K,J) RVCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVCUTEN(I,K,J) RTHCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHCUTEN(I,K,J) @@ -2220,8 +2220,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCCUTEN(I,K,J) ENDDO ENDDO @@ -2230,8 +2230,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRCUTEN(I,K,J) ENDDO ENDDO @@ -2240,8 +2240,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQICUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQICUTEN(I,K,J) ENDDO ENDDO @@ -2250,8 +2250,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSCUTEN(I,K,J) ENDDO ENDDO @@ -2265,8 +2265,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUSHTEN(I,K,J) RVSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVSHTEN(I,K,J) RTHSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHSHTEN(I,K,J) @@ -2277,8 +2277,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCSHTEN(I,K,J) ENDDO ENDDO @@ -2287,8 +2287,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRSHTEN(I,K,J) ENDDO ENDDO @@ -2297,8 +2297,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQISHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQISHTEN(I,K,J) ENDDO ENDDO @@ -2307,8 +2307,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSSHTEN(I,K,J) ENDDO ENDDO @@ -2317,8 +2317,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQGSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQGSHTEN(I,K,J) ENDDO ENDDO diff --git a/dyn_em/module_first_rk_step_part1.F b/dyn_em/module_first_rk_step_part1.F index 8f1ab3cfe7..1f7dce2a93 100644 --- a/dyn_em/module_first_rk_step_part1.F +++ b/dyn_em/module_first_rk_step_part1.F @@ -1112,6 +1112,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & AKHS=grid%akhs ,AKMS=grid%akms & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & & ,WINDFARM_OPT=config_flags%windfarm_opt,power=grid%power & + & ,windfarm_wake_model=config_flags%windfarm_wake_model & ! Yulong add for WLM + & ,windfarm_overlap_method=config_flags%windfarm_overlap_method & ! Yulong add for WLM & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & & ,BLDTACTTIME=grid%bldtacttime & & ,BR=grid%br ,CHKLOWQ=chklowq ,CT=grid%ct & diff --git a/dyn_em/module_initialize_real.F b/dyn_em/module_initialize_real.F index 87830a2f18..673d893c78 100644 --- a/dyn_em/module_initialize_real.F +++ b/dyn_em/module_initialize_real.F @@ -1190,6 +1190,7 @@ SUBROUTINE init_domain_rk ( grid & END IF ! Some data sets do not provide a 3d geopotential height field. + ! This calculation is more accurate if the data is bottom-up. IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN DO j = jts, MIN(jte,jde-1) @@ -1248,6 +1249,15 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF + IF ( flag_sh .EQ. 1 ) THEN + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%q2(i,j)=grid%qv_gc(i,1,j) + END DO + END DO + END IF + ! The requested ptop for real data cases. p_top_requested = grid%p_top_requested @@ -1723,6 +1733,23 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + ! when specific humidity is available, qv_gc is computed from sh_gc + IF (config_flags%use_sh_qv .and. (flag_sh .eq. 1 .or. flag_qv .eq. 1)) THEN + CALL vert_interp ( grid%qv_gc , grid%pd_gc , moist(:,:,:,P_QV) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + ! If this is theta being interpolated, AND we have extra levels for temperature, ! convert those extra levels (trop and max wind) to potential temp. @@ -1793,6 +1820,8 @@ SUBROUTINE init_domain_rk ( grid & its , ite , jts , jte , kts , kte ) END IF + ! do not compute qv from RH if flag_sh or flag_qv = 1, or use_sh_qv = F + IF ( flag_sh .ne. 1 .or. flag_qv .ne. 1 .or. .not. config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & @@ -1814,6 +1843,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF + END IF IF ( .NOT. config_flags%interp_theta ) THEN CALL t_to_theta ( grid%t_2 , grid%p , p00 , & @@ -4069,6 +4099,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + IF ( flag_sh .ne. 1 .or. flag_qv .ne. 1 .or. .not. config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & @@ -4090,6 +4121,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF + END IF ! Compute pressure similarly to how computed within model, with final Qv. diff --git a/dyn_em/solve_em.F b/dyn_em/solve_em.F index 92d5b73fed..39cdf85723 100644 --- a/dyn_em/solve_em.F +++ b/dyn_em/solve_em.F @@ -3810,6 +3810,7 @@ END SUBROUTINE CMAQ_DRIVER & , SNOWNC=grid%snownc, SNOWNCV=grid%snowncv & & , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv & ! for milbrandt2mom & , HAILNC=grid%hailnc, HAILNCV=grid%hailncv & + & , HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & & , W=grid%w_2, Z=grid%z, HT=grid%ht & & , MP_RESTART_STATE=grid%mp_restart_state & & , TBPVS_STATE=grid%tbpvs_state & ! etampnew @@ -3859,11 +3860,11 @@ END SUBROUTINE CMAQ_DRIVER & , QNI3_CURR=scalar(ims,kms,jms,P_QNI3), F_QNI3=F_QNI3 & ! for Jensen ISHMAEL & , QVOLI3_CURR=scalar(ims,kms,jms,P_QVOLI3), F_QVOLI3=F_QVOLI3 & ! for Jensen ISHMAEL & , QAOLI3_CURR=scalar(ims,kms,jms,P_QAOLI3), F_QAOLI3=F_QAOLI3 & ! for Jensen ISHMAEL -! & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom + & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom & , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI & ! for 3-moment P3 ! & , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS & ! " -! & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " -! & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " + & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " + & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " & , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom & , QVOLH_CURR=scalar(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom & , QDCN_CURR=scalar(ims,kms,jms,P_QDCN), F_QDCN=F_QDCN & ! for ntu3m diff --git a/dyn_em/start_em.F b/dyn_em/start_em.F index 941b64a1c5..97a5bfcdcf 100644 --- a/dyn_em/start_em.F +++ b/dyn_em/start_em.F @@ -1234,15 +1234,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%itimestep, grid%fdob, & t00, p00, a, & ! for obs_nudge base state grid%TYR, grid%TYRA, grid%TDLY, grid%TLAG, grid%NYEAR, grid%NDAY,grid%tmn_update, & - grid%achfx, grid%aclhf, grid%acgrdflx, & - config_flags%nssl_cccn, & - config_flags%nssl_alphah, config_flags%nssl_alphahl, & - config_flags%nssl_cnoh, config_flags%nssl_cnohl, & - config_flags%nssl_cnor, config_flags%nssl_cnos, & - config_flags%nssl_rho_qh, config_flags%nssl_rho_qhl, & - config_flags%nssl_rho_qs, & - config_flags%nssl_ipelec, & - config_flags%nssl_isaund & + grid%achfx, grid%aclhf, grid%acgrdflx & ,grid%RQCNCUTEN, grid%RQINCUTEN,grid%rliq & !mchen add for cammpmg ,grid%cldfra_dp,grid%cldfra_sh & ! ckay for subgrid cloud ,grid%te_temf,grid%cf3d_temf,grid%wm_temf & ! WA @@ -1759,8 +1751,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & IF ( f_qnn ) THEN IF ( config_flags%mp_physics == wdm5scheme .or. config_flags%mp_physics == wdm6scheme ) THEN ! NO OP - ELSE IF ( config_flags%mp_physics == nssl_2momccn ) THEN - grid%ccn_conc = config_flags%nssl_cccn/1.225 + ELSE IF ( config_flags%mp_physics == nssl_2mom ) THEN + IF ( config_flags%nssl_ccn_is_ccna == 0 ) THEN + grid%ccn_conc = config_flags%nssl_cccn/1.225 + ELSE + grid%ccn_conc = 0 + ENDIF ELSE ! NO OP END IF diff --git a/main/depend.common b/main/depend.common index 65ee00c3b3..80e6f00a3f 100644 --- a/main/depend.common +++ b/main/depend.common @@ -1,1336 +1,2854 @@ # DEPENDENCIES for frame - module_configure.o: \ - ../dyn_em/namelist_remappings_em.h \ - module_domain_type.o \ - module_state_description.o \ - module_wrf_error.o \ - module_driver_constants.o - -module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \ - module_domain.o \ - module_driver_constants.o \ - module_timing.o \ - module_comm_nesting_dm.o \ - module_configure.o module_comm_dm.o \ - module_cpl.o \ - ../share/module_model_constants.o - -module_timing.o: hires_timer.o clog.o - -module_comm_dm.o: module_comm_dm_0.o module_comm_dm_1.o module_comm_dm_2.o module_comm_dm_3.o module_comm_dm_4.o - -module_comm_dm_0.o: module_domain.o module_configure.o -module_comm_dm_1.o: module_domain.o module_configure.o -module_comm_dm_2.o: module_domain.o module_configure.o -module_comm_dm_3.o: module_domain.o module_configure.o -module_comm_dm_4.o: module_domain.o module_configure.o + ../dyn_em/namelist_remappings_em.h \ + module_domain_type.o \ + module_state_description.o \ + module_wrf_error.o \ + module_driver_constants.o + + +module_dm.o: \ + module_machine.o \ + module_state_description.o \ + module_wrf_error.o \ + module_domain.o \ + module_driver_constants.o \ + module_timing.o \ + module_comm_nesting_dm.o \ + module_configure.o \ + module_comm_dm.o \ + module_cpl.o \ + ../share/module_model_constants.o + + +module_timing.o: \ + module_wrf_error.o \ + hires_timer.o \ + clog.o + + +module_comm_dm.o: \ + module_configure.o \ + module_domain.o \ + module_driver_constants.o \ + module_comm_dm_0.o \ + module_comm_dm_1.o \ + module_comm_dm_2.o \ + module_comm_dm_3.o \ + module_comm_dm_4.o + + +module_comm_dm_0.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_1.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_2.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_3.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_4.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + module_comm_nesting_dm.o: \ - module_domain.o \ - module_configure.o - -module_dm_stubs.F: module_domain.o - -module_domain.o: module_domain_type.o \ - module_alloc_space_0.o \ - module_alloc_space_1.o \ - module_alloc_space_2.o \ - module_alloc_space_3.o \ - module_alloc_space_4.o \ - module_alloc_space_5.o \ - module_alloc_space_6.o \ - module_alloc_space_7.o \ - module_alloc_space_8.o \ - module_alloc_space_9.o \ - module_driver_constants.o \ - module_configure.o \ - module_machine.o \ - module_state_description.o \ - module_wrf_error.o \ - $(ESMF_MOD_DEPENDENCE) - -module_domain_type.o : module_driver_constants.o module_streams.o $(ESMF_MOD_DEPENDENCE) - -module_alloc_space_0.o : module_domain_type.o module_configure.o -module_alloc_space_1.o : module_domain_type.o module_configure.o -module_alloc_space_2.o : module_domain_type.o module_configure.o -module_alloc_space_3.o : module_domain_type.o module_configure.o -module_alloc_space_4.o : module_domain_type.o module_configure.o -module_alloc_space_5.o : module_domain_type.o module_configure.o -module_alloc_space_6.o : module_domain_type.o module_configure.o -module_alloc_space_7.o : module_domain_type.o module_configure.o -module_alloc_space_8.o : module_domain_type.o module_configure.o -module_alloc_space_9.o : module_domain_type.o module_configure.o - -module_streams.o : \ - module_state_description.o + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_dm_stubs.F: \ + module_domain.o + + +module_domain.o: \ + module_domain_type.o \ + module_alloc_space_0.o \ + module_alloc_space_1.o \ + module_alloc_space_2.o \ + module_alloc_space_3.o \ + module_alloc_space_4.o \ + module_alloc_space_5.o \ + module_alloc_space_6.o \ + module_alloc_space_7.o \ + module_alloc_space_8.o \ + module_alloc_space_9.o \ + module_driver_constants.o \ + module_configure.o \ + module_machine.o \ + module_state_description.o \ + module_wrf_error.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_domain_type.o: \ + module_driver_constants.o \ + module_streams.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_alloc_space_0.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_1.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_2.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_3.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_4.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_5.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_6.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_7.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_8.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_9.o: \ + module_domain_type.o \ + module_configure.o + + +module_streams.o: \ + module_state_description.o + module_driver_constants.o: \ - module_state_description.o \ - module_wrf_error.o + module_state_description.o \ + module_wrf_error.o + module_integrate.o: \ - module_domain.o \ - module_timing.o \ - module_driver_constants.o \ - module_state_description.o \ - module_nesting.o \ - module_configure.o \ - $(LLIST) \ - module_cpl.o \ - module_dm.o \ - $(ESMF_MOD_DEPENDENCE) + module_domain.o \ + module_timing.o \ + module_driver_constants.o \ + module_state_description.o \ + module_nesting.o \ + module_configure.o \ + $(LLIST) \ + module_cpl.o \ + module_dm.o \ + $(ESMF_MOD_DEPENDENCE) + module_intermediate_nmm.o: \ - module_state_description.o \ - module_domain.o \ - module_configure.o \ - module_dm.o \ - module_comm_dm.o \ - module_timing.o - -module_io.o : md_calls.inc \ - module_dm.o \ - module_state_description.o \ - module_configure.o \ - module_streams.o \ - module_driver_constants.o + module_state_description.o \ + module_domain.o \ + module_configure.o \ + module_dm.o \ + module_comm_dm.o \ + module_timing.o + + +module_io.o: \ + module_domain.o \ + md_calls.inc \ + module_dm.o \ + module_state_description.o \ + module_configure.o \ + module_streams.o \ + module_driver_constants.o + module_io_quilt.o: \ - module_state_description.o \ - module_dm.o \ - module_configure.o \ - module_internal_header_util.o \ - module_quilt_outbuf_ops.o \ - module_wrf_error.o \ - module_cpl.o + module_state_description.o \ + module_dm.o \ + module_configure.o \ + module_internal_header_util.o \ + module_quilt_outbuf_ops.o \ + module_wrf_error.o \ + module_cpl.o + module_machine.o: \ - module_driver_constants.o + module_driver_constants.o + module_nesting.o: \ - module_machine.o \ - module_driver_constants.o \ - module_configure.o \ - $(ESMF_MOD_DEPENDENCE) \ - module_domain.o + module_machine.o \ + module_driver_constants.o \ + module_configure.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_domain.o + module_quilt_outbuf_ops.o: \ - module_state_description.o module_timing.o - -module_tiles.o: module_domain.o \ - module_driver_constants.o \ - module_machine.o \ - module_configure.o \ - module_wrf_error.o - + module_state_description.o \ + module_timing.o + + +module_tiles.o: \ + module_domain.o \ + module_driver_constants.o \ + module_machine.o \ + module_configure.o \ + module_wrf_error.o + + module_timing.o: \ - module_state_description.o \ - module_wrf_error.o + module_state_description.o \ + module_wrf_error.o + module_wrf_error.o: \ - wrf_shutdown.o \ - clog.o \ - $(ESMF_MOD_DEPENDENCE) + wrf_shutdown.o \ + clog.o \ + $(ESMF_MOD_DEPENDENCE) + wrf_debug.o: \ - module_wrf_error.o + module_wrf_error.o + + +module_sm.o: \ + module_wrf_error.o -module_sm.o: module_wrf_error.o module_cpl.o: \ - ../share/module_model_constants.o \ - module_driver_constants.o \ - module_domain.o \ - module_configure.o \ - module_cpl_oasis3.o + ../share/module_model_constants.o \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o \ + module_cpl_oasis3.o + -module_cpl_oasis3.o: module_driver_constants.o \ - module_domain.o +module_cpl_oasis3.o: \ + module_driver_constants.o \ + module_domain.o -module_clear_halos.o: module_configure.o \ - module_domain.o + +module_clear_halos.o: \ + module_configure.o \ + module_domain.o \ # End of DEPENDENCIES for frame # DEPENDENCIES for phys -module_madwrf.o: ../share/module_model_constants.o \ - ../share/module_soil_pre.o \ - ../phys/module_mp_thompson.o +module_madwrf.o: \ + module_wrf_top.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + module_mp_thompson.o -module_bl_myjpbl.o: ../share/module_model_constants.o -module_bl_myjurb.o: ../share/module_model_constants.o +module_bl_ysu.o: \ + ccpp_kind_types.o \ + physics_mmm/bl_ysu.o + -module_bl_gbmpbl.o: ../share/module_model_constants.o +module_bl_myjpbl.o: \ + ../share/module_model_constants.o -module_bl_boulac.o: ../share/module_model_constants.o -module_bl_qnsepbl.o: ../share/module_model_constants.o +module_bl_myjurb.o: \ + ../share/module_model_constants.o -module_progtm.o: module_gfs_machine.o -module_bl_gfs.o: module_gfs_machine.o \ - module_gfs_physcons.o +module_bl_gbmpbl.o: \ + ../share/module_model_constants.o -module_bl_gfsedmf.o: module_gfs_machine.o \ - module_gfs_physcons.o -module_bl_mynn_common.o: ccpp_kind_types.o +module_bl_boulac.o: \ + ../share/module_model_constants.o -module_bl_mynn.o: module_bl_mynn_common.o -module_bl_mynn_wrapper.o: module_bl_mynn.o \ - module_bl_mynn_common.o +module_bl_qnsepbl.o: \ + ../share/module_model_constants.o -module_cam_upper_bc.o: module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_constituents.o: module_cam_shr_kind_mod.o \ - module_cam_physconst.o \ - module_cam_support.o \ - ../frame/module_wrf_error.o +module_progtm.o: \ + module_gfs_machine.o -module_cam_trb_mtn_stress.o: module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_molec_diff.o: module_cam_support.o \ - module_cam_constituents.o \ - module_cam_upper_bc.o +module_bl_gfs.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_data_cam_mam_aero.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_mp_radconstants.o -module_data_cam_mam_asect.o : module_cam_shr_kind_mod.o \ - module_data_cam_mam_aero.o +module_bl_gfsedmf.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_cam_bl_diffusion_solver.o: module_cam_support.o -module_cam_bl_eddy_diff.o:module_cam_bl_diffusion_solver.o \ - module_cam_support.o +module_bl_mynn.o: \ + module_bl_mynn_common.o -module_bl_camuwpbl_driver.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_constituents.o \ - module_cam_bl_diffusion_solver.o\ - module_cam_physconst.o \ - module_cam_trb_mtn_stress.o \ - module_cam_bl_eddy_diff.o \ - module_cam_wv_saturation.o \ - module_cam_molec_diff.o \ - module_data_cam_mam_aero.o \ - ../share/module_model_constants.o \ - module_cam_esinti.o -module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \ - ../share/module_model_constants.o \ - ../frame/module_wrf_error.o +module_bl_mynn_wrapper.o: \ + module_bl_mynn.o \ + module_bl_mynn_common.o -module_sf_fogdes.o: ../share/module_model_constants.o -module_bl_fogdes.o: ../share/module_model_constants.o +module_bl_gwdo.o: \ + physics_mmm/bl_gwdo.o -module_sf_gfdl.o : \ - module_gfs_machine.o \ - module_sf_exchcoef.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_bmj.o: ../share/module_model_constants.o +module_cam_upper_bc.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_shcu_camuwshcu_driver.o: module_cam_support.o \ - module_mp_cammgmp_driver.o \ - module_cam_physconst.o \ - module_cam_wv_saturation.o \ - module_shcu_camuwshcu.o -module_shcu_camuwshcu.o: module_cam_support.o \ - module_cam_constituents.o \ - module_cam_error_function.o \ - module_cam_esinti.o \ - module_cam_physconst.o \ - module_bl_camuwpbl_driver.o +module_cam_constituents.o: \ + module_cam_shr_kind_mod.o \ + module_cam_physconst.o \ + module_cam_support.o \ + ../frame/module_wrf_error.o -module_shcu_deng.o: -module_cu_camzm_driver.o: ../share/module_model_constants.o \ - module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_mp_cammgmp_driver.o \ - module_bl_camuwpbl_driver.o \ - module_cu_camzm.o +module_cam_trb_mtn_stress.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_cu_camzm.o: module_cam_shr_kind_mod.o \ - module_cam_constituents.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_wv_saturation.o \ - module_cam_cldwat.o -module_cam_error_function.o: +module_cam_molec_diff.o: \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_upper_bc.o -module_cam_cldwat.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_wv_saturation.o \ - module_cam_physconst.o -module_cam_esinti.o: module_cam_shr_kind_mod.o \ - module_cam_wv_saturation.o +module_data_cam_mam_aero.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_mp_radconstants.o -module_cam_wv_saturation.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_gffgch.o -module_cam_gffgch.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o +module_data_cam_mam_asect.o: \ + module_cam_shr_kind_mod.o \ + module_data_cam_mam_aero.o -module_cam_physconst.o: module_cam_shr_kind_mod.o \ - module_cam_shr_const_mod.o -module_cam_shr_const_mod.o: module_cam_shr_kind_mod.o +module_cam_bl_diffusion_solver.o: \ + module_cam_support.o -module_cam_support.o: module_cam_shr_kind_mod.o \ - ../frame/module_state_description.o -module_cam_shr_kind_mod.o: +module_cam_bl_eddy_diff.o: \ + module_cam_bl_diffusion_solver.o \ + module_cam_support.o -module_cu_kf.o: ../frame/module_wrf_error.o +module_bl_camuwpbl_driver.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_bl_diffusion_solver.o \ + module_cam_physconst.o \ + module_cam_trb_mtn_stress.o \ + module_cam_bl_eddy_diff.o \ + module_cam_wv_saturation.o \ + module_cam_molec_diff.o \ + module_data_cam_mam_aero.o \ + ../share/module_model_constants.o \ + module_cam_esinti.o -module_cu_kfcup.o: ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - $(CF2) \ - ../share/module_model_constants.o \ - module_mixactivate.o - -module_cu_kfeta.o: ../frame/module_wrf_error.o - -module_cu_gd.o: - -module_cu_ksas.o: - -module_cu_nsas.o: - -module_cu_du.o: ../frame/module_wrf_error.o - -module_gfs_physcons.o: module_gfs_machine.o -module_gfs_funcphys.o: module_gfs_machine.o \ - module_gfs_physcons.o +module_sf_mynn.o: \ + module_sf_sfclay.o \ + module_bl_mynn.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o -module_cu_sas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_scalesas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_osas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o +module_sf_fogdes.o: \ + ../share/module_model_constants.o -module_cu_tiedtke.o:module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_ntiedtke.o: ../share/module_model_constants.o +module_bl_fogdes.o: \ + ../share/module_model_constants.o -module_ra_gfdleta.o: ../frame/module_dm.o \ - module_mp_etanew.o -module_ra_rrtm.o: ../frame/module_wrf_error.o \ - module_ra_clWRF_support.o \ - ../frame/module_dm.o +module_sf_gfdl.o: \ + module_gfs_machine.o \ + module_sf_exchcoef.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_ra_cam_support.o: module_cam_support.o \ - ../frame/module_wrf_error.o -module_ra_cam.o: module_ra_cam_support.o \ - module_cam_support.o \ - module_ra_clWRF_support.o \ - ../frame/module_wrf_error.o +module_cu_bmj.o: \ + ../share/module_model_constants.o -module_mp_lin.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_ra_flg.o: ../frame/module_wrf_error.o \ - ../frame/module_dm.o +module_shcu_camuwshcu_driver.o: \ + module_data_cam_mam_asect.o \ + module_cam_support.o \ + module_mp_cammgmp_driver.o \ + module_cam_physconst.o \ + module_cam_wv_saturation.o \ + module_shcu_camuwshcu.o -module_mp_sbu_ylin.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o -module_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_shcu_camuwshcu.o: \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_error_function.o \ + module_cam_esinti.o \ + module_cam_physconst.o \ + module_bl_camuwpbl_driver.o -module_mp_thompson.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_mp_nssl_2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_shcu_deng.o: \ + ../frame/module_wrf_error.o -module_mp_fast_sbm.o : module_mp_radar.o -module_mp_full_sbm.o : module_mp_radar.o +module_cu_camzm_driver.o: \ + module_data_cam_mam_asect.o \ + ../share/module_model_constants.o \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_mp_cammgmp_driver.o \ + module_bl_camuwpbl_driver.o \ + module_cu_camzm.o -module_mp_cammgmp_driver.o : module_cam_mp_microp_aero.o \ - module_cam_constituents.o \ - module_cam_shr_kind_mod.o \ - module_cam_cldwat.o \ - module_cam_mp_cldwat2m_micro.o \ - module_cam_physconst.o \ - module_cam_support.o \ - module_data_cam_mam_aero.o \ - module_data_cam_mam_asect.o \ - module_cam_wv_saturation.o \ - module_cam_mp_ndrop.o \ - module_cam_mp_conv_water.o \ - ../frame/module_state_description.o -module_cam_mp_microp_aero.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o \ - module_cam_mp_ndrop.o \ - module_data_cam_mam_aero.o -module_cam_mp_cldwat2m_micro.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o +module_cu_camzm.o: \ + module_cam_shr_kind_mod.o \ + module_cam_constituents.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_wv_saturation.o \ + module_cam_cldwat.o -module_cam_mp_ndrop.o : module_cam_shr_kind_mod.o \ - module_data_cam_mam_aero.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_constituents.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o -module_cam_mp_modal_aero_initialize_data_phys.o : module_data_cam_mam_aero.o -module_cam_mp_conv_water.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o +module_cam_error_function.o: \ -module_cam_mp_qneg3.o: module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_mp_radconstants.o : module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_infnan.o: module_cam_shr_kind_mod.o +module_cam_cldwat.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_wv_saturation.o \ + module_cam_physconst.o -module_mp_gsfcgce.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_sf_myjsfc.o: ../share/module_model_constants.o +module_cam_esinti.o: \ + module_cam_shr_kind_mod.o \ + module_cam_wv_saturation.o -module_sf_qnsesfc.o: ../share/module_model_constants.o -module_sf_gfs.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o \ - module_progtm.o +module_cam_wv_saturation.o: \ + ../frame/module_wrf_error.o \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_gffgch.o -module_sf_noahdrv.o: module_sf_noahlsm.o \ - module_sf_noahlsm_glacial_only.o \ - module_data_gocart_dust.o \ - module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o -module_sf_noahlsm.o: ../share/module_model_constants.o +module_cam_gffgch.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o -module_sf_clm.o: module_cam_shr_kind_mod.o \ - module_cam_shr_const_mod.o \ - module_cam_support.o \ - module_sf_urban.o \ - module_sf_noahlsm.o \ - module_ra_gfdleta.o \ - ../share/module_date_time.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o -module_sf_ctsm.o: ../frame/module_dm.o \ - ../frame/module_configure.o \ - ../frame/module_wrf_error.o +module_cam_physconst.o: \ + module_cam_shr_kind_mod.o \ + module_cam_shr_const_mod.o -module_sf_ssib.o: ../share/module_model_constants.o -module_sf_noah_seaice_drv.o: module_sf_noah_seaice.o +module_cam_shr_const_mod.o: \ + module_cam_shr_kind_mod.o -module_sf_noah_seaice.o: module_sf_noahlsm.o ../share/module_model_constants.o -module_sf_noahmpdrv.o: module_sf_noahmplsm.o \ - module_data_gocart_dust.o \ - module_sf_noahmp_glacier.o \ - module_sf_noahmp_groundwater.o \ - module_sf_gecros.o \ - ../share/module_model_constants.o \ - module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o +module_cam_support.o: \ + ../frame/module_wrf_error.o \ + module_cam_shr_kind_mod.o \ + ../frame/module_state_description.o -module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o -module_sf_noahmplsm.o: ../share/module_model_constants.o \ - module_sf_gecros.o \ - module_sf_myjsfc.o - -module_sf_noahmp_groundwater.o: module_sf_noahmplsm.o - -module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o module_bep_bem_helper.o - -module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o module_sf_urban.o module_bep_bem_helper.o +module_cam_shr_kind_mod.o: \ -module_sf_bem.o: ../share/module_model_constants.o -module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o +module_cu_kf.o: \ + ../frame/module_wrf_error.o -module_sf_pxlsm.o: ../share/module_model_constants.o module_sf_pxlsm_data.o -module_ra_rrtmg_sw.o: module_ra_rrtmg_aero_optical_util_cmaq.o module_ra_rrtmg_lw.o -module_ra_rrtmg_swf.o: module_ra_rrtmg_lwf.o -module_ra_rrtmg_swk.o: module_ra_rrtmg_lwk.o module_ra_effective_radius.o +module_cu_kfcup.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + $(CF2) \ + ../share/module_model_constants.o \ + module_mixactivate.o -module_ra_rrtmg_lw.o: ../share/module_model_constants.o \ - module_ra_clWRF_support.o -module_ra_rrtmg_lwf.o: ../share/module_model_constants.o \ - module_ra_clWRF_support.o -module_ra_rrtmg_lwk.o: ../share/module_model_constants.o +module_cu_kfeta.o: \ + ../frame/module_wrf_error.o -module_physics_addtendc.o: \ - module_cu_kf.o \ - module_cu_kfeta.o \ - $(PHYS_CU) \ - ../frame/module_state_description.o \ - ../frame/module_configure.o - -module_physics_init.o : \ - module_ra_rrtm.o \ - module_ra_rrtmg_lwf.o \ - module_ra_rrtmg_swf.o \ - module_ra_rrtmg_lw.o \ - module_ra_rrtmg_sw.o \ - module_ra_rrtmg_lwk.o \ - module_ra_rrtmg_swk.o \ - module_ra_cam.o \ - $(PHYS_CU) $(PHYS_BL) \ - module_ra_cam_support.o \ - module_ra_clWRF_support.o \ - module_ra_sw.o \ - module_ra_gsfcsw.o \ - module_ra_gfdleta.o \ - module_ra_hs.o \ - module_ra_flg.o \ - module_sf_sfclay.o \ - module_sf_sfclayrev.o \ - module_sf_slab.o \ - module_sf_myjsfc.o \ - module_sf_mynn.o \ - module_sf_fogdes.o \ - module_sf_urban.o \ - module_sf_qnsesfc.o \ - module_sf_pxsfclay.o \ - module_sf_noahlsm.o \ - module_sf_noahdrv.o \ - module_sf_clm.o \ - module_sf_ctsm.o \ - module_sf_ssib.o \ - module_sf_noahmplsm.o \ - module_sf_noahmpdrv.o \ - module_sf_bep.o \ - module_sf_bep_bem.o \ - module_sf_ruclsm.o \ - module_sf_pxlsm.o \ - module_sf_lake.o \ - module_bl_ysu.o \ - module_bl_mrf.o \ - module_bl_gfs.o \ - module_bl_gfsedmf.o \ - module_bl_acm.o \ - module_bl_myjpbl.o \ - module_bl_qnsepbl.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ - module_bl_myjurb.o \ - module_bl_boulac.o \ - module_bl_camuwpbl_driver.o \ - module_bl_temf.o \ - module_bl_mfshconvpbl.o \ - module_cu_kf.o \ - module_cu_g3.o \ - module_cu_kfeta.o \ - module_cu_mskf.o \ - module_cu_bmj.o \ - module_cu_gd.o \ - module_cu_ksas.o \ - module_cu_nsas.o \ - module_cu_sas.o \ - module_cu_scalesas.o \ - module_cu_osas.o \ - module_cu_camzm_driver.o \ - module_cu_kfcup.o \ - module_shcu_camuwshcu.o \ - module_shcu_deng.o \ - module_shcu_grims.o \ - module_mp_sbu_ylin.o \ - module_mp_wsm3.o \ - module_mp_wsm5.o \ - module_mp_wsm6.o \ - module_mp_wsm6r.o \ - module_mp_etanew.o \ - module_mp_fer_hires.o \ - module_mp_fast_sbm.o \ - module_fdda_psufddagd.o \ - module_fdda_spnudging.o \ - module_fddaobs_rtfdda.o \ - module_mp_thompson.o \ - module_mp_gsfcgce.o \ - module_mp_gsfcgce_4ice_nuwrf.o \ - module_mp_morr_two_moment.o \ - module_mp_milbrandt2mom.o \ - module_mp_nssl_2mom.o \ - module_mp_wdm5.o \ - module_mp_wdm6.o \ - module_cam_physconst.o \ - module_cam_shr_kind_mod.o \ - module_mp_cammgmp_driver.o \ - module_cam_esinti.o \ - module_cam_constituents.o \ - module_cam_mp_modal_aero_initialize_data_phys.o \ - module_cam_support.o \ - module_wind_fitch.o \ - module_gocart_coupling.o \ - module_data_gocart_dust.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_wrf_error.o \ - ../frame/module_dm.o \ - ../share/module_llxy.o \ - ../share/module_model_constants.o -module_microphysics_driver.o: \ - module_mixactivate.o \ - module_mp_kessler.o module_mp_sbu_ylin.o module_mp_lin.o \ - $(PHYS_MP) \ - module_mp_wsm3.o module_mp_wsm5.o \ - module_mp_wsm6.o module_mp_etanew.o \ - module_mp_wsm6r.o \ - module_mp_fer_hires.o \ - module_mp_thompson.o \ - module_mp_gsfcgce.o \ - module_mp_gsfcgce_4ice_nuwrf.o \ - module_mp_morr_two_moment.o \ - module_mp_morr_two_moment_aero.o \ - module_mp_milbrandt2mom.o \ - module_mp_nssl_2mom.o \ - module_mp_wdm5.o module_mp_wdm6.o \ - module_mp_cammgmp_driver.o \ - module_irrigation.o \ - module_mp_fast_sbm.o \ - ../frame/module_driver_constants.o \ - ../frame/module_state_description.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o \ - ../frame/module_comm_dm.o \ - ../frame/module_dm.o \ - ../share/module_model_constants.o +module_cu_gd.o: \ -module_shallowcu_driver.o: \ - module_shcu_camuwshcu_driver.o \ - module_shcu_deng.o \ - ../frame/module_state_description.o \ - ../share/module_model_constants.o -module_cu_gf_deep.o: \ - module_cu_gf_ctrans.o -module_cu_gf_wrfdrv.o: \ - module_cu_gf_deep.o \ - module_cu_gf_sh.o -module_cu_gf_sh.o: \ - module_cu_gf_deep.o -module_cu_gf_ctrans.o: \ - ../chem/module_chem_utilities.o \ - ../share/module_HLaw.o \ - ../share/module_ctrans_aqchem.o \ - ../frame/module_state_description.o -module_cumulus_driver.o: \ - module_cu_kf.o \ - module_cu_g3.o \ - module_cu_gf_wrfdrv.o \ - module_cu_kfeta.o \ - $(PHYS_CU) \ - module_cu_bmj.o \ - module_cu_gd.o \ - module_cu_ksas.o \ - module_cu_nsas.o \ - module_cu_sas.o \ - module_cu_scalesas.o \ - module_cu_osas.o \ - module_cu_camzm_driver.o \ - module_cu_tiedtke.o \ - module_cu_ntiedtke.o \ - module_cu_mskf.o \ - module_cu_kfcup.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_wrf_error.o \ - ../share/module_model_constants.o - -module_pbl_driver.o: \ - module_bl_myjpbl.o \ - module_bl_myjurb.o \ - module_bl_qnsepbl.o \ - module_bl_acm.o \ - module_bl_ysu.o \ - module_bl_mrf.o \ - module_bl_boulac.o \ - module_bl_camuwpbl_driver.o \ - module_bl_gfs.o \ - module_bl_gfsedmf.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ - module_bl_fogdes.o \ - module_bl_gwdo.o \ - module_bl_gwdo_gsl.o \ - module_bl_temf.o \ - module_bl_mfshconvpbl.o \ - $(PHYS_BL) \ - module_wind_fitch.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../share/module_model_constants.o - -module_data_gocart_dust.o: +module_cu_ksas.o: \ -module_mixactivate.o: \ - module_radiation_driver.o -module_radiation_driver.o: \ - module_ra_sw.o \ - module_ra_gsfcsw.o \ - module_ra_rrtm.o \ - module_ra_rrtmg_lw.o \ - module_ra_rrtmg_sw.o \ - module_ra_rrtmg_aero_optical_util_cmaq.o \ - module_ra_rrtmg_lwf.o \ - module_ra_rrtmg_swf.o \ - module_ra_rrtmg_lwk.o \ - module_ra_rrtmg_swk.o \ - module_ra_cam.o \ - module_ra_farms.o \ - module_ra_gfdleta.o \ - module_ra_hs.o \ - module_ra_goddard.o \ - module_ra_flg.o \ - module_ra_eclipse.o \ - module_ra_aerosol.o \ - module_mp_thompson.o \ - ../frame/module_driver_constants.o \ - ../frame/module_state_description.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_domain.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o \ - ../share/module_bc.o \ - ../share/module_model_constants.o +module_cu_nsas.o: \ -module_surface_driver.o: \ - module_sf_sfclay.o \ - module_sf_sfclayrev.o \ - module_sf_slab.o \ - module_sf_myjsfc.o \ - module_sf_qnsesfc.o \ - module_sf_pxsfclay.o \ - module_sf_gfs.o \ - module_sf_noah_seaice_drv.o \ - module_sf_noahmp_groundwater.o \ - module_sf_noahdrv.o \ - module_sf_clm.o \ - module_sf_ctsm.o \ - module_sf_ssib.o \ - module_sf_noahmpdrv.o \ - module_sf_ruclsm.o \ - module_sf_pxlsm.o \ - module_sf_mynn.o \ - module_sf_fogdes.o \ - module_sf_sfcdiags.o \ - module_sf_sfcdiags_ruclsm.o \ - module_sf_sstskin.o \ - module_sf_lake.o \ - module_sf_tmnupdate.o \ - module_sf_temfsfclay.o \ - module_sf_idealscmsfclay.o \ - module_sf_scmflux.o \ - module_sf_scmskintemp.o \ - module_sf_ocean_driver.o \ - module_irrigation.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_cpl.o \ - ../share/module_model_constants.o - -module_sf_ocean_driver.o : \ - module_sf_oml.o \ - module_sf_3dpwp.o \ - ../frame/module_state_description.o -module_diagnostics_driver.o: \ - module_lightning_driver.o \ - module_diag_misc.o \ - module_diag_nwp.o \ - module_diag_cl.o \ - module_diag_pld.o \ - module_diag_zld.o \ - module_diag_afwa.o \ - module_diag_hailcast.o \ - module_diag_rasm.o \ - module_diag_trad_fields.o \ - module_diag_solar.o \ - ../frame/module_comm_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_driver_constants.o \ - ../share/module_model_constants.o +module_cu_du.o: \ + ../frame/module_wrf_error.o -module_diag_misc.o: \ - ../frame/module_dm.o -module_diag_cl.o: \ - ../frame/module_dm.o \ - ../frame/module_configure.o +module_gfs_physcons.o: \ + module_gfs_machine.o -module_diag_pld.o: \ - ../share/module_model_constants.o -module_diag_zld.o: \ - ../share/module_model_constants.o +module_gfs_funcphys.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_diag_afwa.o: \ - module_diag_trad_fields.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_streams.o \ - ../external/esmf_time_f90/module_utility.o \ - ../share/module_model_constants.o -module_diag_hailcast.o: \ - ../frame/module_configure.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_streams.o \ - ../external/esmf_time_f90/module_utility.o \ - ../share/module_model_constants.o +module_cu_sas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_rasm.o: \ - module_cam_shr_const_mod.o -module_diag_trad_fields.o: \ - module_diag_functions.o \ - ../share/module_model_constants.o +module_cu_scalesas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_solar.o: \ - ../share/module_model_constants.o -module_diag_refl.o: \ - ../frame/module_dm.o \ - ../share/module_model_constants.o +module_cu_osas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_mixactivate.o: \ - module_radiation_driver.o -module_fddagd_driver.o: \ - module_fdda_spnudging.o \ - module_fdda_psufddagd.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../share/module_model_constants.o +module_cu_tiedtke.o: \ + ../share/module_model_constants.o \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_fddaobs_driver.o: \ - ../frame/module_domain.o \ - ../share/module_bc.o \ - ../share/module_model_constants.o \ - module_fddaobs_rtfdda.o -module_sf_lake.o : \ - ../share/module_model_constants.o - +module_cu_ntiedtke.o: \ + ../share/module_model_constants.o \ + ccpp_kind_types.o \ + physics_mmm/cu_ntiedtke.o -module_fr_fire_driver.o: \ - ../share/module_model_constants.o \ - ../frame/module_comm_dm.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - module_fr_fire_phys.o \ - module_fr_fire_model.o \ - module_fr_fire_util.o \ - module_fr_fire_core.o \ - module_fr_fire_atm.o -module_fr_fire_driver_wrf.o: \ - ../share/module_model_constants.o \ - ../frame/module_comm_dm.o \ - module_fr_fire_driver.o \ - module_fr_fire_atm.o \ - module_fr_fire_util.o +module_ra_gfdleta.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + ../frame/module_dm.o \ + module_mp_etanew.o -module_fr_fire_atm.o: \ - ../share/module_model_constants.o \ - module_fr_fire_util.o -module_fr_fire_model.o: \ - module_fr_fire_core.o \ - module_fr_fire_phys.o \ - module_fr_fire_util.o +module_ra_rrtm.o: \ + ../frame/module_wrf_error.o \ + module_ra_clWRF_support.o \ + ../frame/module_dm.o -module_fr_fire_core.o: \ - module_fr_fire_util.o \ - module_fr_fire_phys.o -module_fr_fire_phys.o: \ - ../share/module_model_constants.o \ - module_fr_fire_util.o +module_ra_cam_support.o: \ + module_cam_support.o \ + ../frame/module_wrf_error.o -module_fire_debug_output.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../share/mediation_integrate.o -module_firebrand_spotting_mpi.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o +module_ra_cam.o: \ + module_ra_cam_support.o \ + module_ra_clWRF_support.o \ + module_ra_cam_support.o \ + module_cam_support.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o -module_firebrand_spotting.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain_type.o \ - ../external/esmf_time_f90/module_symbols_util.o \ - ../external/esmf_time_f90/module_utility.o \ - module_firebrand_spotting_mpi.o -module_fdda_spnudging.o :\ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o \ - ../frame/module_wrf_error.o +module_mp_lin.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -module_sf_bep.o :\ - module_sf_urban.o -module_mp_wsm5.o :\ - module_mp_wsm5_accel.F \ - module_mp_radar.o +module_ra_flg.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o -module_mp_wdm5.o :\ - module_mp_radar.o -module_mp_wsm6.o :\ - module_mp_radar.o +module_mp_sbu_ylin.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_mp_wdm6.o :\ - module_mp_radar.o -module_mp_morr_two_moment.o :\ - module_mp_radar.o +module_mp_milbrandt2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_mp_wsm3.o :\ - module_mp_wsm3_accel.F -module_mp_radar.o : +module_mp_thompson.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -module_lightning_driver.o : \ - module_ltng_crmpr92.o module_ltng_cpmpr92z.o module_ltng_iccg.o -module_ltng_cpmpr92z.o : +module_mp_nssl_2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_ltng_crmpr92.o : -module_ltng_iccg.o : +module_mp_fast_sbm.o: \ + ../frame/module_domain.o \ + module_mp_SBM_polar_radar.o \ + module_mp_radar.o -module_ra_aerosol.o :\ - ../frame/module_wrf_error.o -module_gocart_coupling.o: +module_mp_full_sbm.o: \ + module_mp_radar.o -module_ra_goddard.o : ../frame/module_wrf_error.o \ - module_gocart_coupling.o \ - module_checkerror.o -module_mp_gsfcgce_4ice_nuwrf.o : ../frame/module_wrf_error.o \ - module_gocart_coupling.o \ - module_checkerror.o \ - module_mp_radar.o +module_mp_cammgmp_driver.o: \ + ../frame/module_configure.o \ + module_cam_mp_microp_aero.o \ + module_cam_constituents.o \ + module_cam_shr_kind_mod.o \ + module_cam_cldwat.o \ + module_cam_mp_cldwat2m_micro.o \ + module_cam_physconst.o \ + module_cam_support.o \ + module_data_cam_mam_aero.o \ + module_data_cam_mam_asect.o \ + module_cam_wv_saturation.o \ + module_cam_mp_ndrop.o \ + module_cam_mp_conv_water.o \ + ../frame/module_state_description.o -# End of DEPENDENCIES for phys +module_cam_mp_microp_aero.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o \ + module_cam_mp_ndrop.o \ + module_data_cam_mam_aero.o -# DEPENDENCIES for share -module_trajectory.o: ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_state_description.o \ - module_model_constants.o \ - module_date_time.o \ - module_llxy.o +module_cam_mp_cldwat2m_micro.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o -solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o ../frame/module_driver_constants.o \ - ../frame/module_wrf_error.o \ - ../frame/module_state_description.o ../phys/module_checkerror.o \ - ../frame/module_wrf_error.o module_trajectory.o -start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o ../share/module_llxy.o +module_cam_mp_ndrop.o: \ + module_cam_shr_kind_mod.o \ + module_data_cam_mam_aero.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_constituents.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o -module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o \ - module_model_constants.o -module_bc.o: ../frame/module_configure.o ../frame/module_state_description.o \ - ../frame/module_wrf_error.o module_model_constants.o +module_cam_mp_modal_aero_initialize_data_phys.o: \ + module_data_cam_mam_aero.o -module_bc_time_utilities.o: $(ESMF_MOD_DEPENDENCE) -module_get_file_names.o: ../frame/module_dm.o +module_cam_mp_conv_water.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o -module_io_wrf.o: module_date_time.o \ - ../frame/module_wrf_error.o ../frame/module_streams.o \ - $(ESMF_MOD_DEPENDENCE) -module_io_domain.o: module_io_wrf.o module_date_time.o ../frame/module_io.o \ - ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_state_description.o +module_cam_mp_qneg3.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_state_description.o \ - ../frame/module_configure.o module_io_wrf.o \ - $(ESMF_MOD_DEPENDENCE) -wrf_fddaobs_in.o: \ - module_date_time.o \ - module_llxy.o - -wrf_timeseries.o: wrf_tsin.o \ - module_model_constants.o \ - module_llxy.o \ - module_model_constants.o \ - module_string_tools.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o - -track_driver.o: track_input.o \ - module_model_constants.o \ - module_llxy.o \ - module_date_time.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_dm.o - -input_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_state_description.o \ - ../frame/module_configure.o module_io_wrf.o \ - $(ESMF_MOD_DEPENDENCE) - -wrf_ext_write_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_timing.o - -wrf_ext_read_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_timing.o - -module_soil_pre.o: module_date_time.o ../frame/module_state_description.o - -module_check_a_mundo.o: ../frame/module_configure.o ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - ../share/module_model_constants.o \ - ../phys/module_bep_bem_helper.o - -dfi.o : ../frame/module_wrf_error.o ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o ../frame/module_timing.o \ - ../frame/module_machine.o ../frame/module_comm_dm.o \ - ../frame/module_dm.o ../frame/module_driver_constants.o \ - module_model_constants.o module_date_time.o module_io_domain.o \ - $(ESMF_MOD_DEPENDENCE) - -module_optional_input.o: module_io_wrf.o module_io_domain.o \ - ../frame/module_domain.o ../frame/module_configure.o - -mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_dm.o \ - ../frame/module_timing.o $(ESMF_MOD_DEPENDENCE) \ - module_bc_time_utilities.o module_io_domain.o - -init_modules.o: ../frame/module_configure.o ../frame/module_driver_constants.o \ - ../frame/module_domain.o ../frame/module_machine.o \ - ../frame/module_nesting.o ../frame/module_timing.o \ - ../frame/module_tiles.o ../frame/module_io.o \ - ../frame/module_io_quilt.o ../frame/module_dm.o \ - ../external/io_int/io_int.o \ - module_io_wrf.o module_bc.o module_model_constants.o \ - ../frame/module_wrf_error.o - -interp_fcn.o: ../frame/module_timing.o ../frame/module_state_description.o ../frame/module_configure.o \ - ../frame/module_wrf_error.o module_model_constants.o module_interp_nmm.o module_interp_store.o - -module_interp_nmm.o: module_model_constants.o module_interp_store.o - -mediation_feedback_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_intermediate_nmm.o - -mediation_force_domain.o: ../frame/module_domain.o ../frame/module_configure.o - -mediation_integrate.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o \ - $(ESMF_MOD_DEPENDENCE) \ - module_date_time.o module_bc_time_utilities.o \ - module_compute_geop.o \ - $(PERTMOD) \ - module_io_domain.o - - -mediation_interp_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o +module_cam_mp_radconstants.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -mediation_nest_move.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_driver_constants.o \ - module_io_domain.o - -#mediation_conv_emissions.o: ../frame/module_domain.o ../frame/module_configure.o \ -# ../external/esmf_time_f90/ESMF_Mod.o \ -# module_date_time.o module_bc_time_utilities.o \ -# module_io_domain.o - -set_timekeeping.o: ../frame/module_domain.o ../frame/module_configure.o \ - $(ESMF_MOD_DEPENDENCE) - -wrf_inputout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput1out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput2out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput3out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput4out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput5out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput6out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput7out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput8out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput9out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput10out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput11out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_histout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist1out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist2out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist3out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist4out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist5out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist6out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist7out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist8out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist9out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist10out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist11out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_restartout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_bdyout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_inputin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist1in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist2in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist3in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist4in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist5in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist6in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist7in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist8in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist9in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist10in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist11in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput1in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput2in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput3in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput4in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput5in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput6in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput7in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput8in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput9in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput10in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput11in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_bdyin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_histin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_restartin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_tsin.o : ../frame/module_domain.o - -track_input.o : ../frame/module_domain.o - -module_random.o: bobrand.o -# End of DEPENDENCIES for share +module_cam_infnan.o: \ + module_cam_shr_kind_mod.o -# DEPENDENCIES for main +module_mp_gsfcgce.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -convert_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../share/module_bc.o \ - ../share/module_io_domain.o \ - $(ESMF_MOD_DEPENDENCE) -ideal_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../share/module_io_domain.o \ - ../dyn_$(SOLVER)/$(CASE_MODULE) \ - $(ESMF_MOD_DEPENDENCE) +module_sf_myjsfc.o: \ + ../share/module_model_constants.o -ndown_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ + +module_sf_qnsesfc.o: \ + ../share/module_model_constants.o + + +module_sf_gfs.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o \ + module_progtm.o + + +module_sf_noahdrv.o: \ + module_ra_gfdleta.o \ + ../frame/module_wrf_error.o \ + module_sf_noahlsm.o \ + module_sf_noahlsm_glacial_only.o \ + module_data_gocart_dust.o \ + module_sf_urban.o \ + module_sf_bep.o \ + module_sf_bep_bem.o + + +module_sf_noahlsm.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_sf_clm.o: \ + module_cam_shr_kind_mod.o \ + module_cam_shr_const_mod.o \ + module_cam_support.o \ + module_sf_urban.o \ + module_sf_noahlsm.o \ + module_ra_gfdleta.o \ + ../share/module_date_time.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o + + +module_sf_ctsm.o: \ ../frame/module_dm.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o + + +module_sf_ssib.o: \ + ../share/module_model_constants.o + + +module_sf_noah_seaice_drv.o: \ ../frame/module_wrf_error.o \ - ../frame/module_integrate.o \ - ../share/module_bc.o \ - ../share/module_io_domain.o \ - ../share/module_get_file_names.o \ + module_sf_noah_seaice.o + + +module_sf_noah_seaice.o: \ ../share/module_model_constants.o \ - ../share/module_soil_pre.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../dyn_em/nest_init_utils.o \ - $(ESMF_MOD_DEPENDENCE) + module_sf_noahlsm.o \ + module_sf_noahlsm.o \ + ../share/module_model_constants.o -# this already built above :../dyn_em/module_initialize.real.o \ -real_em.o: \ - ../frame/module_machine.o \ + +module_sf_noahmpdrv.o: \ + ../frame/module_comm_dm.o \ ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../share/module_io_domain.o \ - ../share/module_date_time.o \ - ../share/module_optional_input.o \ - ../share/module_bc_time_utilities.o \ - ../dyn_em/module_wps_io_arw.o \ - $(ESMF_MOD_DEPENDENCE) -# ../chem/module_input_chem_data.o \ -# ../chem/module_input_chem_bioemiss.o \ + module_ra_gfdleta.o \ + module_sf_noahmplsm.o \ + module_data_gocart_dust.o \ + module_sf_noahmp_glacier.o \ + module_sf_noahmp_groundwater.o \ + module_sf_gecros.o \ + ../share/module_model_constants.o \ + module_sf_urban.o \ + module_sf_bep.o \ + module_sf_bep_bem.o -tc_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../share/module_io_domain.o \ - ../share/module_date_time.o \ - ../share/module_optional_input.o \ - ../share/module_bc_time_utilities.o \ - $(ESMF_MOD_DEPENDENCE) +module_sf_noahlsm_glacial_only.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_sf_noahlsm.o \ + module_sf_noahmplsm.o + + +module_sf_noahmplsm.o: \ + ../share/module_model_constants.o \ + module_sf_gecros.o \ + module_sf_myjsfc.o + + +module_sf_noahmp_groundwater.o: \ + module_sf_noahmplsm.o + +module_sf_bep.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_sf_urban.o \ + module_bep_bem_helper.o + + +module_sf_bep_bem.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_sf_bem.o \ + module_sf_urban.o \ + module_bep_bem_helper.o + + +module_sf_bem.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_sf_ruclsm.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_data_gocart_dust.o + + +module_sf_pxlsm.o: \ + ../share/module_model_constants.o \ + module_sf_pxlsm_data.o -wrf.o: ../main/module_wrf_top.o +module_sf_sfclayrev.o: \ + ccpp_kind_types.o \ + physics_mmm/sf_sfclayrev.o -wrf_ESMFMod.o: ../main/module_wrf_top.o -wrf_SST_ESMF.o: wrf_ESMFMod.o +module_ra_rrtmg_sw.o: \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o \ + module_ra_rrtmg_aero_optical_util_cmaq.o \ + module_ra_rrtmg_lw.o + + +module_ra_rrtmg_swf.o: \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o \ + module_ra_rrtmg_lwf.o + + +module_ra_rrtmg_swk.o: \ + ../share/module_model_constants.o \ + module_ra_rrtmg_lwk.o \ + module_ra_effective_radius.o + + +module_ra_rrtmg_lw.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o + -module_wrf_top.o: ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_integrate.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - ../frame/module_cpl.o \ - $(ESMF_MOD_DEPENDENCE) +module_ra_rrtmg_lwf.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o -# End of DEPENDENCIES for main +module_ra_rrtmg_lwk.o: \ + ../share/module_model_constants.o + + +module_physics_addtendc.o: \ + module_cu_kf.o \ + module_cu_kfeta.o \ + $(PHYS_CU) \ + ../frame/module_state_description.o \ + ../frame/module_configure.o + + +module_physics_init.o: \ + module_bl_gbmpbl.o \ + module_bl_shinhong.o \ + module_cu_ntiedtke.o \ + module_cu_tiedtke.o \ + ../frame/module_domain.o \ + module_mp_full_sbm.o \ + module_mp_jensen_ishmael.o \ + module_mp_morr_two_moment_aero.o \ + module_mp_ntu.o \ + module_mp_wdm7.o \ + module_mp_wsm7.o \ + module_ra_goddard.o \ + module_sf_gfdl.o \ + module_sf_oml.o \ + module_sf_temfsfclay.o \ + module_shcu_nscv.o \ + module_ra_rrtm.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ + module_ra_rrtmg_lw.o \ + module_ra_rrtmg_sw.o \ + module_ra_rrtmg_lwk.o \ + module_ra_rrtmg_swk.o \ + module_ra_cam.o \ + $(PHYS_CU) \ + $(PHYS_BL) \ + module_ra_cam_support.o \ + module_ra_clWRF_support.o \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_gfdleta.o \ + module_ra_hs.o \ + module_ra_flg.o \ + module_sf_sfclay.o \ + module_sf_sfclayrev.o \ + physics_mmm/sf_sfclayrev.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_mynn.o \ + module_sf_fogdes.o \ + module_sf_urban.o \ + module_sf_qnsesfc.o \ + module_sf_pxsfclay.o \ + module_sf_noahlsm.o \ + module_sf_noahdrv.o \ + module_sf_clm.o \ + module_sf_ctsm.o \ + module_sf_ssib.o \ + module_sf_noahmplsm.o \ + module_sf_noahmpdrv.o \ + module_sf_bep.o \ + module_sf_bep_bem.o \ + module_sf_ruclsm.o \ + module_sf_pxlsm.o \ + module_sf_lake.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_gfs.o \ + module_bl_gfsedmf.o \ + module_bl_acm.o \ + module_bl_myjpbl.o \ + module_bl_qnsepbl.o \ + module_bl_mynn.o \ + module_bl_mynn_wrapper.o \ + module_bl_myjurb.o \ + module_bl_boulac.o \ + module_bl_camuwpbl_driver.o \ + module_bl_temf.o \ + module_bl_mfshconvpbl.o \ + module_cu_kf.o \ + module_cu_g3.o \ + module_cu_kfeta.o \ + module_cu_mskf.o \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_ksas.o \ + module_cu_nsas.o \ + module_cu_sas.o \ + module_cu_scalesas.o \ + module_cu_osas.o \ + module_cu_camzm_driver.o \ + module_cu_kfcup.o \ + module_shcu_camuwshcu.o \ + module_shcu_deng.o \ + module_shcu_grims.o \ + module_mp_sbu_ylin.o \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + physics_mmm/mp_wsm6.o \ + module_mp_wsm6r.o \ + module_mp_etanew.o \ + module_mp_fer_hires.o \ + module_mp_fast_sbm.o \ + module_fdda_psufddagd.o \ + module_fdda_spnudging.o \ + module_fddaobs_rtfdda.o \ + module_mp_thompson.o \ + module_mp_gsfcgce.o \ + module_mp_gsfcgce_4ice_nuwrf.o \ + module_mp_morr_two_moment.o \ + module_mp_milbrandt2mom.o \ + module_mp_nssl_2mom.o \ + module_mp_wdm5.o \ + module_mp_wdm6.o \ + module_cam_physconst.o \ + module_cam_shr_kind_mod.o \ + module_mp_cammgmp_driver.o \ + module_cam_esinti.o \ + module_cam_constituents.o \ + module_cam_mp_modal_aero_initialize_data_phys.o \ + module_cam_support.o \ + module_wind_fitch.o \ + module_wind_mav.o \ + module_gocart_coupling.o \ + module_data_gocart_dust.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o + + +module_microphysics_driver.o: \ + ../frame/module_domain.o \ + module_fire_emis.o \ + module_mp_full_sbm.o \ + module_mp_jensen_ishmael.o \ + module_mp_ntu.o \ + module_mp_wdm7.o \ + module_mp_wsm7.o \ + module_mixactivate.o \ + module_mp_kessler.o \ + module_mp_sbu_ylin.o \ + module_mp_lin.o \ + $(PHYS_MP) \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + module_mp_wsm6.o \ + module_mp_etanew.o \ + module_mp_wsm6r.o \ + module_mp_fer_hires.o \ + module_mp_thompson.o \ + module_mp_gsfcgce.o \ + module_mp_gsfcgce_4ice_nuwrf.o \ + module_mp_morr_two_moment.o \ + module_mp_morr_two_moment_aero.o \ + module_mp_milbrandt2mom.o \ + module_mp_nssl_2mom.o \ + module_mp_wdm5.o \ + module_mp_wdm6.o \ + module_mp_cammgmp_driver.o \ + module_irrigation.o \ + module_mp_fast_sbm.o \ + ../frame/module_driver_constants.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../frame/module_comm_dm.o \ + ../frame/module_dm.o \ + ../share/module_model_constants.o + + +module_shallowcu_driver.o: \ + ../frame/module_domain.o \ + module_shcu_grims.o \ + module_shcu_nscv.o \ + module_shcu_camuwshcu_driver.o \ + module_shcu_deng.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o + + +module_cu_gf_deep.o: \ + module_cu_gf_ctrans.o + + +module_cu_gf_wrfdrv.o: \ + module_cu_gf_ctrans.o \ + module_gfs_physcons.o \ + module_cu_gf_deep.o \ + module_cu_gf_sh.o + + +module_cu_gf_sh.o: \ + module_cu_gf_ctrans.o \ + module_cu_gf_deep.o + + +module_cu_gf_ctrans.o: \ + ../chem/module_chem_utilities.o \ + ../share/module_HLaw.o \ + ../share/module_ctrans_aqchem.o \ + ../frame/module_state_description.o + + +module_cumulus_driver.o: \ + ../share/module_chem_share.o \ + module_cu_kf.o \ + module_cu_g3.o \ + module_cu_gf_wrfdrv.o \ + module_cu_kfeta.o \ + $(PHYS_CU) \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_ksas.o \ + module_cu_nsas.o \ + module_cu_sas.o \ + module_cu_scalesas.o \ + module_cu_osas.o \ + module_cu_camzm_driver.o \ + module_cu_tiedtke.o \ + module_cu_ntiedtke.o \ + module_cu_mskf.o \ + module_cu_kfcup.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_pbl_driver.o: \ + module_bl_gbmpbl.o \ + module_bl_keps.o \ + module_bl_shinhong.o \ + module_bl_myjpbl.o \ + module_bl_myjurb.o \ + module_bl_qnsepbl.o \ + module_bl_acm.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_boulac.o \ + module_bl_camuwpbl_driver.o \ + module_bl_gfs.o \ + module_bl_gfsedmf.o \ + module_bl_mynn.o \ + module_bl_mynn_wrapper.o \ + module_bl_fogdes.o \ + module_bl_gwdo.o \ + module_bl_gwdo_gsl.o \ + module_bl_temf.o \ + module_bl_mfshconvpbl.o \ + $(PHYS_BL) \ + module_wind_fitch.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_data_gocart_dust.o: \ + + +module_mixactivate.o: \ + ../share/module_model_constants.o \ + module_radiation_driver.o + + +module_radiation_driver.o: \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_rrtm.o \ + module_ra_rrtmg_lw.o \ + module_ra_rrtmg_sw.o \ + module_ra_rrtmg_aero_optical_util_cmaq.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ + module_ra_rrtmg_lwk.o \ + module_ra_rrtmg_swk.o \ + module_ra_cam.o \ + module_ra_farms.o \ + module_ra_gfdleta.o \ + module_ra_hs.o \ + module_ra_goddard.o \ + module_ra_flg.o \ + module_ra_eclipse.o \ + module_ra_aerosol.o \ + module_mp_thompson.o \ + ../frame/module_driver_constants.o \ + ../frame/module_state_description.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../share/module_bc.o \ + ../share/module_model_constants.o + + +module_surface_driver.o: \ + module_sf_noahlsm.o \ + module_sf_sfclay.o \ + module_sf_sfclayrev.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_qnsesfc.o \ + module_sf_pxsfclay.o \ + module_sf_gfs.o \ + module_sf_noah_seaice_drv.o \ + module_sf_noahmp_groundwater.o \ + module_sf_noahdrv.o \ + module_sf_clm.o \ + module_sf_ctsm.o \ + module_sf_ssib.o \ + module_sf_noahmpdrv.o \ + module_sf_ruclsm.o \ + module_sf_pxlsm.o \ + module_sf_mynn.o \ + module_sf_fogdes.o \ + module_sf_sfcdiags.o \ + module_sf_sfcdiags_ruclsm.o \ + module_sf_sstskin.o \ + module_sf_lake.o \ + module_sf_tmnupdate.o \ + module_sf_temfsfclay.o \ + module_sf_idealscmsfclay.o \ + module_sf_scmflux.o \ + module_sf_scmskintemp.o \ + module_sf_ocean_driver.o \ + module_irrigation.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_cpl.o \ + ../share/module_model_constants.o + + +module_sf_ocean_driver.o: \ + module_sf_oml.o \ + module_sf_3dpwp.o \ + ../frame/module_state_description.o + + +module_diagnostics_driver.o: \ + ../frame/module_streams.o \ + module_lightning_driver.o \ + module_diag_misc.o \ + module_diag_nwp.o \ + module_diag_cl.o \ + module_diag_pld.o \ + module_diag_zld.o \ + module_diag_afwa.o \ + module_diag_hailcast.o \ + module_diag_rasm.o \ + module_diag_trad_fields.o \ + module_diag_solar.o \ + ../frame/module_comm_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../share/module_model_constants.o + + +module_diag_misc.o: \ + ../frame/module_dm.o + + +module_diag_cl.o: \ + ../frame/module_dm.o \ + ../frame/module_configure.o + + +module_diag_pld.o: \ + ../share/module_model_constants.o + + +module_diag_zld.o: \ + ../share/module_model_constants.o + + +module_diag_afwa.o: \ + module_diag_trad_fields.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_streams.o \ + ../external/esmf_time_f90/module_utility.o \ + ../share/module_model_constants.o + + +module_diag_hailcast.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_streams.o \ + ../external/esmf_time_f90/module_utility.o \ + ../share/module_model_constants.o + + +module_diag_rasm.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_streams.o \ + module_cam_shr_const_mod.o + + +module_diag_trad_fields.o: \ + module_diag_functions.o \ + ../share/module_model_constants.o + + +module_diag_solar.o: \ + ../share/module_model_constants.o + + +module_diag_refl.o: \ + ../frame/module_dm.o \ + ../share/module_model_constants.o + + +module_mixactivate.o: \ + module_radiation_driver.o + + +module_fddagd_driver.o: \ + ../frame/module_domain.o \ + module_fdda_spnudging.o \ + module_fdda_psufddagd.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_fddaobs_driver.o: \ + ../frame/module_domain.o \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + module_fddaobs_rtfdda.o + + +module_sf_lake.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_fr_fire_driver.o: \ + ../share/module_model_constants.o \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + module_fr_fire_phys.o \ + module_fr_fire_model.o \ + module_fr_fire_util.o \ + module_fr_fire_core.o \ + module_fr_fire_atm.o + + +module_fr_fire_driver_wrf.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_comm_dm.o \ + module_fr_fire_driver.o \ + module_fr_fire_atm.o \ + module_fr_fire_util.o + + +module_fr_fire_atm.o: \ + ../share/module_model_constants.o \ + module_fr_fire_util.o + + +module_fr_fire_model.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_fr_fire_core.o \ + module_fr_fire_phys.o \ + module_fr_fire_util.o + + +module_fr_fire_core.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_fr_fire_util.o \ + module_fr_fire_phys.o + + +module_fr_fire_phys.o: \ + ../share/module_model_constants.o \ + module_fr_fire_util.o + + +module_fire_debug_output.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../share/mediation_integrate.o + + +module_firebrand_spotting_mpi.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o + + +module_firebrand_spotting.o: \ + ../frame/module_domain_type.o \ + module_firebrand_spotting_mpi.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain_type.o \ + ../external/esmf_time_f90/module_symbols_util.o \ + ../external/esmf_time_f90/module_utility.o \ + module_firebrand_spotting_mpi.o + + +module_fdda_spnudging.o: \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o + + +module_sf_bep.o: \ + module_sf_urban.o + + +module_mp_wsm5.o: \ + ../share/module_model_constants.o \ + module_mp_wsm5_accel.F \ + module_mp_radar.o + + +module_mp_wdm5.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm6.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_wsm6_effectRad.o \ + physics_mmm/mp_radar.o \ + physics_mmm/mp_wsm6.o + +module_mp_wdm6.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_morr_two_moment.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm3.o: \ + ../share/module_model_constants.o \ + module_mp_wsm3_accel.F + + +module_mp_radar.o: \ + ../frame/module_wrf_error.o + + +module_lightning_driver.o: \ + module_ltng_lpi.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_ltng_crmpr92.o \ + module_ltng_cpmpr92z.o \ + module_ltng_iccg.o + + +module_ltng_cpmpr92z.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_ltng_crmpr92.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_ltng_iccg.o: \ + + +module_ra_aerosol.o: \ + ../frame/module_wrf_error.o + + +module_gocart_coupling.o: \ + + +module_ra_goddard.o: \ + ../frame/module_wrf_error.o \ + module_gocart_coupling.o \ + module_checkerror.o + + +module_mp_gsfcgce_4ice_nuwrf.o: \ + ../frame/module_wrf_error.o \ + module_gocart_coupling.o \ + module_checkerror.o \ + module_mp_radar.o \ + + +physics_mmm/sf_sfclayrev.o: \ + ccpp_kind_types.o + + +physics_mmm/cu_ntiedtke.o: \ + ccpp_kind_types.o + + +physics_mmm/mp_wsm6.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_radar.o \ + physics_mmm/module_libmassv.o + + +physics_mmm/mp_wsm6_effectRad.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_wsm6.o + + +physics_mmm/bl_ysu.o: \ + ccpp_kind_types.o + + +physics_mmm/bl_gwdo.o : \ + ccpp_kind_types.o + + +# End of DEPENDENCIES for phys + + +# DEPENDENCIES for share + +module_trajectory.o: \ + ../frame/module_domain_type.o \ + ../frame/module_driver_constants.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_state_description.o \ + module_model_constants.o \ + module_date_time.o \ + module_llxy.o + + +solve_interface.o: \ + solve_em.int \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_driver_constants.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../phys/module_checkerror.o \ + ../frame/module_wrf_error.o \ + module_trajectory.o + + +start_domain.o: \ + start_domain_em.int \ + wrf_timeseries.o \ + track_driver.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../share/module_llxy.o + + +module_date_time.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + module_model_constants.o + + +module_bc.o: \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + module_model_constants.o + + +module_bc_time_utilities.o: \ + $(ESMF_MOD_DEPENDENCE) + + +module_get_file_names.o: \ + ../frame/module_dm.o + + +module_io_wrf.o: \ + module_date_time.o \ + ../frame/module_wrf_error.o \ + ../frame/module_streams.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_io_domain.o: \ + module_io_wrf.o \ + module_date_time.o \ + ../frame/module_io.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o + + +output_wrf.o: \ + ../frame/module_domain_type.o \ + module_model_constants.o \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_fddaobs_in.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_model_constants.o \ + module_date_time.o \ + module_llxy.o + + +wrf_timeseries.o: \ + wrf_tsin.o \ + module_model_constants.o \ + module_llxy.o \ + module_model_constants.o \ + module_string_tools.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o + + +track_driver.o: \ + track_input.o \ + module_model_constants.o \ + module_llxy.o \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_dm.o + + +input_wrf.o: \ + module_bc_time_utilities.o \ + module_date_time.o \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_ext_write_field.o: \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o + + +wrf_ext_read_field.o: \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o + + +module_soil_pre.o: \ + module_date_time.o \ + ../frame/module_state_description.o + + +module_check_a_mundo.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o \ + ../phys/module_bep_bem_helper.o + + +dfi.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o \ + ../frame/module_machine.o \ + ../frame/module_comm_dm.o \ + ../frame/module_dm.o \ + ../frame/module_driver_constants.o \ + module_model_constants.o \ + module_date_time.o \ + module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_optional_input.o: \ + module_io_wrf.o \ + module_io_domain.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o + + +mediation_wrfmain.o: \ + ../frame/module_io.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_bc_time_utilities.o \ + module_io_domain.o + + +init_modules.o: \ + ../frame/module_cpl.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../frame/module_domain.o \ + ../frame/module_machine.o \ + ../frame/module_nesting.o \ + ../frame/module_timing.o \ + ../frame/module_tiles.o \ + ../frame/module_io.o \ + ../frame/module_io_quilt.o \ + ../frame/module_dm.o \ + ../external/io_int/io_int.o \ + module_io_wrf.o \ + module_bc.o \ + module_model_constants.o \ + ../frame/module_wrf_error.o + + +interp_fcn.o: \ + ../frame/module_timing.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + module_model_constants.o \ + module_interp_nmm.o \ + module_interp_store.o + + +module_interp_nmm.o: \ + module_model_constants.o \ + module_interp_store.o + + +mediation_feedback_domain.o: \ + ../frame/module_timing.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_intermediate_nmm.o + + +mediation_force_domain.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o + + +mediation_integrate.o: \ + module_bc.o \ + ../dyn_em/module_bc_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_streams.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_date_time.o \ + module_bc_time_utilities.o \ + module_compute_geop.o \ + $(PERTMOD) \ + module_io_domain.o + + +mediation_interp_domain.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o + + +mediation_nest_move.o: \ + module_compute_geop.o \ + ../frame/module_streams.o \ + ../frame/module_timing.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_driver_constants.o \ + module_io_domain.o + + +#mediation_conv_emissions.o: \ +# ../frame/module_domain.o \ +# ../frame/module_configure.o \ +# ../external/esmf_time_f90/ESMF_Mod.o \ +# module_date_time.o \ +# module_bc_time_utilities.o \ +# module_io_domain.o + + +set_timekeeping.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_inputout.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput1out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput2out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput3out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput4out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput5out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput6out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput7out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput8out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput9out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput10out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput11out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_histout.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist1out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist2out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist3out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist4out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist5out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist6out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist7out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist8out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist9out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist10out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist11out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_restartout.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_bdyout.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_inputin.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist1in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist2in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist3in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist4in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist5in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist6in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist7in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist8in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist9in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist10in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist11in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput1in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput2in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput3in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput4in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput5in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput6in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput7in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput8in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput9in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput10in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput11in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_bdyin.o: \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_histin.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_restartin.o: \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_tsin.o: \ + ../frame/module_domain.o + + +track_input.o: \ + ../frame/module_domain.o + + +module_random.o: \ + bobrand.o \ + +# End of DEPENDENCIES for share + +# DEPENDENCIES for main + +convert_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + + +ideal_em.o: \ + ../share/module_check_a_mundo.o \ + ../dyn_em/module_initialize_ideal.o \ + ../frame/module_wrf_error.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../dyn_$(SOLVER)/$(CASE_MODULE) \ + $(ESMF_MOD_DEPENDENCE) + + +ndown_em.o: \ + ../share/module_check_a_mundo.o \ + ../frame/module_domain_type.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_optional_input.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../frame/module_wrf_error.o \ + ../frame/module_integrate.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + ../share/module_get_file_names.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../dyn_em/nest_init_utils.o \ + $(ESMF_MOD_DEPENDENCE) \ + + +# this already built above :../dyn_em/module_initialize.real.o \ +real_em.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o \ + ../dyn_em/module_wps_io_arw.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_io_domain.o \ + ../share/module_date_time.o \ + ../share/module_optional_input.o \ + ../share/module_bc_time_utilities.o \ + ../dyn_em/module_wps_io_arw.o \ + $(ESMF_MOD_DEPENDENCE) \ +# ../chem/module_input_chem_data.o \ +# ../chem/module_input_chem_bioemiss.o + + +tc_em.o: \ + ../share/module_bc.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_llxy.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_io_domain.o \ + ../share/module_date_time.o \ + ../share/module_optional_input.o \ + ../share/module_bc_time_utilities.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf.o: \ + ../main/module_wrf_top.o + + +wrf_ESMFMod.o: \ + ../share/module_bc_time_utilities.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../share/module_io_domain.o \ + ../frame/module_streams.o \ + ../main/module_wrf_top.o + + +wrf_SST_ESMF.o: \ + ../frame/module_io.o \ + wrf_ESMFMod.o + + +module_wrf_top.o: \ + ../share/module_check_a_mundo.o \ + ../share/module_date_time.o \ + ../share/module_io_domain.o \ + ../frame/module_nesting.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_integrate.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../frame/module_cpl.o \ + $(ESMF_MOD_DEPENDENCE) \ + +# End of DEPENDENCIES for main + +ideal_nmm.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_ideal.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o + + +real_nmm.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o + + +module_dm_stubs.o: \ + module_driver_constants.o + + +module_io_quilt_old.o: \ + module_configure.o \ + module_cpl.o \ + module_driver_constants.o \ + module_internal_header_util.o \ + module_quilt_outbuf_ops.o \ + module_timing.o \ + module_wrf_error.o + + +module_bl_eepsilon.o: \ + ../share/module_model_constants.o + + +module_bl_mfshconvpbl.o: \ + ../share/module_model_constants.o + + +module_bl_mynn_common.o: \ + module_gfs_machine.o \ + ../share/module_model_constants.o \ + ccpp_kind_types.o + + +module_cu_mskf.o: \ + ../frame/module_wrf_error.o + + +module_diag_nwp.o: \ + module_mp_thompson.o + + +module_dust_emis.o: \ + module_data_gocart_dust.o + + +module_fddaobs_rtfdda.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o + + +module_fdda_psufddagd.o: \ + ../share/module_model_constants.o + + +module_fr_fire_util.o: \ + ../frame/module_wrf_error.o + + +module_gocart_seasalt.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_microphysics_zero_out.o: \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o + + +module_mp_jensen_ishmael.o: \ + ../frame/module_wrf_error.o + + +module_mp_morr_two_moment_aero.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wdm7.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm7.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_ra_clWRF_support.o: \ + ../frame/module_wrf_error.o + + +module_ra_effective_radius.o: \ + ../share/module_model_constants.o + + +module_ra_farms.o: \ + ../share/module_model_constants.o + + +module_ra_rrtmg_aero_optical_util_cmaq.o: \ + complex_number_module.o + + +module_sf_sstskin.o: \ + ../frame/module_wrf_error.o + + +module_sf_urban.o: \ + ../frame/module_wrf_error.o + + +module_wind_fitch.o: \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o + + +module_interp_store.o: \ + ../frame/module_domain_type.o + + +module_llxy.o: \ + ../frame/module_wrf_error.o + + +wrf_tsin.o: \ + ../frame/module_configure.o \ + module_string_tools.o + + +adapt_timestep_em.o: \ + module_bc_em.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o + + +couple_or_uncouple_em.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_machine.o \ + ../frame/module_tiles.o + + +interp_domain_em.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o + + +module_advect_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_after_all_rk_steps.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../phys/module_diagnostics_driver.o \ + ../frame/module_domain.o + + +module_avgflx_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_bc_em.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_big_step_utilities_em.o: \ + ../frame/module_configure.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_damping_em.o: \ + ../frame/module_wrf_error.o + + +module_diffusion_em.o: \ + ../share/module_bc.o \ + module_big_step_utilities_em.o \ + ../share/module_model_constants.o + + +module_em.o: \ + module_advect_em.o \ + module_big_step_utilities_em.o \ + ../frame/module_configure.o \ + module_damping_em.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + module_ieva_em.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../share/module_trajectory.o + + +module_first_rk_step_part1.o: \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + module_convtrans_prep.o \ + ../phys/module_cumulus_driver.o \ + ../frame/module_domain.o \ + module_em.o \ + ../phys/module_fddagd_driver.o \ + module_force_scm.o \ + ../phys/module_fr_fire_driver_wrf.o \ + ../share/module_model_constants.o \ + ../phys/module_pbl_driver.o \ + ../phys/module_radiation_driver.o \ + ../phys/module_shallowcu_driver.o \ + ../phys/module_surface_driver.o + + +module_first_rk_step_part2.o: \ + ../share/module_bc.o \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + module_diffusion_em.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + module_em.o \ + ../phys/module_fddaobs_driver.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_addtendc.o \ + module_sfs_driver.o \ + module_stoch.o + + +module_force_scm.o: \ + module_init_utilities.o + + +module_ieva_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_initialize_fire.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../phys/module_fr_fire_phys.o \ + ../phys/module_fr_fire_util.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_heldsuarez.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_timing.o + + +module_initialize_ideal.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_real.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../share/module_io_domain.o \ + ../share/module_llxy.o \ + ../phys/module_madwrf.o \ + ../share/module_model_constants.o \ + ../share/module_optional_input.o \ + module_polarfft.o \ + ../phys/module_radiation_driver.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_scm_xy.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_optional_input.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_tropical_cyclone.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_polarfft.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_positive_definite.o: \ + ../frame/module_wrf_error.o + + +module_sfs_driver.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_machine.o \ + ../share/module_model_constants.o \ + module_sfs_nba.o \ + ../frame/module_tiles.o + + +module_sfs_nba.o: \ + ../frame/module_configure.o + + +module_small_step_em.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_stoch.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o + + +module_wps_io_arw.o: \ + ../frame/module_domain.o \ + ../frame/module_internal_header_util.o \ + ../share/module_optional_input.o \ + ../share/module_soil_pre.o + + +nest_init_utils.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_machine.o \ + ../share/module_model_constants.o \ + ../frame/module_tiles.o + + +shift_domain_em.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_domain_type.o \ + ../frame/module_timing.o + + +solve_em.o: \ + module_after_all_rk_steps.o \ + module_avgflx_em.o \ + ../share/module_bc.o \ + module_bc_em.o \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_cpl.o \ + module_diffusion_em.o \ + ../frame/module_domain.o \ + ../frame/module_domain_type.o \ + ../frame/module_driver_constants.o \ + ../phys/module_dust_emis.o \ + module_em.o \ + ../phys/module_fddaobs_driver.o \ + ../phys/module_firebrand_spotting.o \ + module_first_rk_step_part1.o \ + module_first_rk_step_part2.o \ + ../share/module_llxy.o \ + ../frame/module_machine.o \ + ../phys/module_microphysics_driver.o \ + ../phys/module_microphysics_zero_out.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_addtendc.o \ + module_polarfft.o \ + module_small_step_em.o \ + module_solvedebug_em.o \ + ../frame/module_tiles.o + +start_em.o : \ + module_avgflx_em.o \ + ../share/module_bc.o \ + module_bc_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../phys/module_diag_pld.o \ + ../phys/module_diag_zld.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../phys/module_firebrand_spotting.o \ + ../phys/module_fr_fire_driver_wrf.o \ + ../phys/module_lightning_driver.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_init.o \ + ../phys/noahmp/drivers/wrf/module_sf_noahmpdrv.o \ + module_stoch.o \ + ../frame/module_tiles.o \ + ../share/module_trajectory.o \ + ../frame/module_wrf_error.o diff --git a/phys/Makefile b/phys/Makefile index c57fcf0e58..a7fb3dafe4 100644 --- a/phys/Makefile +++ b/phys/Makefile @@ -204,6 +204,7 @@ MODULES = \ module_fddaobs_rtfdda.o \ module_fddaobs_driver.o \ module_wind_fitch.o \ + module_wind_mav.o \ module_sf_lake.o \ module_diagnostics_driver.o \ module_irrigation.o @@ -232,6 +233,16 @@ DIAGNOSTIC_MODULES_EM = \ module_diag_trad_fields.o \ module_diag_solar.o +PHYSMMM_MODULES = \ + physics_mmm/sf_sfclayrev.o \ + physics_mmm/cu_ntiedtke.o \ + physics_mmm/module_libmassv.o \ + physics_mmm/mp_wsm6.o \ + physics_mmm/mp_wsm6_effectRad.o \ + physics_mmm/mp_radar.o \ + physics_mmm/bl_gwdo.o \ + physics_mmm/bl_ysu.o + OBJS = LIBTARGET = physics @@ -240,11 +251,11 @@ TARGETDIR = ./ $(LIBTARGET) : $(MAKE) $(J) non_nmm ; \ $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \ - $(FIRE_MODULES) $(DIAGNOSTIC_MODULES_EM) + $(FIRE_MODULES) $(DIAGNOSTIC_MODULES_EM) $(PHYSMMM_MODULES) include ../configure.wrf -non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM) +non_nmm : $(MODULES) $(FIRE_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM) submodules : @if [ \( ! -f module_sf_noahmpdrv.F \) -o \( ! -f module_sf_noahmp_glacier.F \) -o \ diff --git a/phys/module_bl_gwdo.F b/phys/module_bl_gwdo.F index c81e67c33e..81026c6404 100644 --- a/phys/module_bl_gwdo.F +++ b/phys/module_bl_gwdo.F @@ -1,21 +1,32 @@ -!WRF:model_layer:physics -! -module module_bl_gwdo -contains -!------------------------------------------------------------------------------- - subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & - rublten,rvblten, & - dtaux3d,dtauy3d,dusfcg,dvsfcg, & - var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & - sina,cosa,znu,znw,p_top, & - cp,g,rd,rv,ep1,pi, & - dt,dx,kpbl2d,itimestep, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- +!================================================================================================================= + module module_bl_gwdo + use ccpp_kind_types,only: kind_phys + + use bl_gwdo,only: bl_gwdo_run + + + implicit none + private + public:: gwdo + + + contains + + +!================================================================================================================= + subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & + rublten,rvblten, & + dtaux3d,dtauy3d,dusfcg,dvsfcg, & + var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa,znu,znw,p_top, & + cp,g,rd,rv,ep1,pi, & + dt,dx,kpbl2d,itimestep, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + errmsg,errflg & + ) +!================================================================================================================= ! !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) @@ -56,672 +67,177 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & !-- kts start index for k in tile !-- kte end index for k in tile ! -!------------------------------------------------------------------------------- - integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent(in ) :: itimestep -! - real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: qv3d, & - p3d, & - pi3d, & - t3d, & - z - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: p3di -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & - rvblten - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: dtaux3d, & - dtauy3d -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: u3d, & - v3d -! - integer, dimension( ims:ime, jms:jme ) , & - intent(in ) :: kpbl2d - real, dimension( ims:ime, jms:jme ) , & - intent(inout ) :: dusfcg, & - dvsfcg -! - real, dimension( ims:ime, jms:jme ) , & - intent(in ) :: var2d, & - oc12d, & - oa2d1,oa2d2,oa2d3,oa2d4, & - ol2d1,ol2d2,ol2d3,ol2d4, & - sina,cosa -! - real, dimension( kms:kme ) , & - optional , & - intent(in ) :: znu, & - znw -! - real, optional, intent(in ) :: p_top -! -!local -! - real, dimension( its:ite, kts:kte ) :: delprsi, & - pdh - real, dimension( its:ite, kts:kte ) :: ugeo, vgeo, dudt, dvdt, dtaux, dtauy - real, dimension( its:ite ) :: dusfc, dvsfc - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite, 4 ) :: oa4, & - ol4 - integer :: i,j,k,kpblmax -! - do k = kts,kte - if (znu(k).gt.0.6) kpblmax = k + 1 - enddo -! - do j = jts,jte - do k = kts,kte+1 - do i = its,ite - if (k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo -! - do k = kts,kte - do i = its,ite - delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1) -! rotate winds to zonal/meridional - ugeo(i,k) = u3d(i,k,j)*cosa(i,j) - v3d(i,k,j)*sina(i,j) - vgeo(i,k) = u3d(i,k,j)*sina(i,j) + v3d(i,k,j)*cosa(i,j) - dudt(i,k) = 0.0 - dvdt(i,k) = 0.0 - enddo - enddo - do i = its,ite - oa4(i,1) = oa2d1(i,j) - oa4(i,2) = oa2d2(i,j) - oa4(i,3) = oa2d3(i,j) - oa4(i,4) = oa2d4(i,j) - ol4(i,1) = ol2d1(i,j) - ol4(i,2) = ol2d2(i,j) - ol4(i,3) = ol2d3(i,j) - ol4(i,4) = ol2d4(i,j) - enddo - call gwdo2d(dudt=dudt(its,kts),dvdt=dvdt(its,kts) & - ,dtaux2d=dtaux(its,kts),dtauy2d=dtauy(its,kts) & - ,u1=ugeo(its,kts),v1=vgeo(its,kts) & - ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & - ,del=delprsi(its,kts) & - ,prsi=pdhi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & - ,zl=z(ims,kms,j) & - ,kpblmax=kpblmax & - ,var=var2d(ims,j),oc1=oc12d(ims,j) & - ,oa4=oa4,ol4=ol4 & - ,dusfc=dusfc(its),dvsfc=dvsfc(its) & - ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & - ,dxmeter=dx,deltim=dt & - ,kpbl=kpbl2d(ims,j),lat=j & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) - do k = kts,kte - do i = its,ite -! rotate tendencies from zonal/meridional to model grid - rublten(i,k,j) = rublten(i,k,j)+dudt(i,k)*cosa(i,j) + dvdt(i,k)*sina(i,j) - rvblten(i,k,j) = rvblten(i,k,j)-dudt(i,k)*sina(i,j) + dvdt(i,k)*cosa(i,j) - dtaux3d(i,k,j) = dtaux(i,k)*cosa(i,j) + dtauy(i,k)*sina(i,j) - dtauy3d(i,k,j) =-dtaux(i,k)*sina(i,j) + dtauy(i,k)*cosa(i,j) - if(k.eq.kts)then - dusfcg(i,j) = dusfc(i)*cosa(i,j) + dvsfc(i)*sina(i,j) - dvsfcg(i,j) =-dusfc(i)*sina(i,j) + dvsfc(i)*cosa(i,j) - endif - enddo - enddo - enddo -! - end subroutine gwdo -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - subroutine gwdo2d(dudt, dvdt, dtaux2d, dtauy2d, & - u1, v1, t1, q1, & - del, & - prsi, prsl, prslk, zl, & - kpblmax, & - var, oc1, oa4, ol4, dusfc, dvsfc, & - g_, cp_, rd_, rv_, fv_, pi_, & - dxmeter, deltim, kpbl, lat, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!------------------------------------------------------------------------------- -! -! abstract : -! this code handles the time tendencies of u v due to the effect of -! mountain induced gravity wave drag from sub-grid scale orography. -! this routine not only treats the traditional upper-level wave breaking due -! to mountain variance (alpert 1988), but also the enhanced -! lower-tropospheric wave breaking due to mountain convexity and asymmetry -! (kim and arakawa 1995). thus, in addition to the terrain height data -! in a model grid gox, additional 10-2d topographic statistics files are -! needed, including orographic standard deviation (var), convexity (oc1), -! asymmetry (oa4) and ol (ol4). these data sets are prepared based on the -! 30 sec usgs orography (hong 1999). the current scheme was implmented as in -! choi and hong (2015), which names kim gwdo since it was developed by -! kiaps staffs for kiaps integrated model system (kim). the scheme -! additionally includes the effects of orographic anisotropy and -! flow-blocking drag. -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! history log : -! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy -! -! references : -! choi and hong (2015), j. geophys. res. -! hong et al. (2008), wea. forecasting -! kim and doyle (2005), q. j. r. meteor. soc. -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference -! hong (1999), NCEP office note 424 -! -! input : -! dudt, dvdt - non-lin tendency for u and v wind component -! u1, v1 - zonal and meridional wind m/sec at t0-dt -! t1 - temperature deg k at t0-dt -! q1 - mixing ratio at t0-dt -! deltim - time step (s) -! del - positive increment of pressure across layer (pa) -! kpblmax, kpbl - vertical index of pbl height -! prslk, zl, prsl, prsi - pressure and height variables -! oa4, ol4, omax, var, oc1 - orographic statistics -! -! output : -! dudt, dvdt - wind tendency due to gwdo -! dtaux2d, dtauy2d - diagnoised orographic gwd -! dusfc, dvsfc - gw stress -! -!------------------------------------------------------------------------------- - implicit none -! - integer , intent(in ) :: lat, kpblmax, & - ids, ide, jds, jde, & - kds, kde, ims, ime, & - jms, jme, kms, kme, & - its, ite, jts, jte, & - kts, kte - integer, dimension(ims:ime) , intent(in ) :: kpbl - real , intent(in ) :: g_, pi_, rd_, rv_, fv_,& - cp_, deltim - real , intent(in ) :: dxmeter - real, dimension(its:ite,kts:kte) , intent(inout) :: dudt, dvdt - real, dimension(its:ite,kts:kte) , intent( out) :: dtaux2d, dtauy2d - real, dimension(its:ite,kts:kte) , intent(in ) :: u1, v1 - real, dimension(ims:ime,kms:kme) , intent(in ) :: t1, q1, prslk, zl -! - real, dimension(its:ite,kts:kte) , intent(in ) :: prsl, del - real, dimension(its:ite,kts:kte+1), intent(in ) :: prsi - real, dimension(its:ite,4) , intent(in ) :: oa4, ol4 -! - real, dimension(ims:ime) , intent(in ) :: var, oc1 - real, dimension(its:ite) , intent( out) :: dusfc, dvsfc -! - real, parameter :: ric = 0.25 ! critical richardson number - real, parameter :: dw2min = 1. - real, parameter :: rimin = -100. - real, parameter :: bnv2min = 1.0e-5 - real, parameter :: efmin = 0.0 - real, parameter :: efmax = 10.0 - real, parameter :: xl = 4.0e4 - real, parameter :: critac = 1.0e-5 - real, parameter :: gmax = 1. - real, parameter :: veleps = 1.0 - real, parameter :: frc = 1.0 - real, parameter :: ce = 0.8 - real, parameter :: cg = 0.5 - integer,parameter :: kpblmin = 2 -! -! local variables -! - integer :: latd,lond - integer :: i,k,lcap,lcapp1,nwd,idir, & - klcap,kp1,ikount,kk -! - real :: fdir,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy -! - logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 - real, dimension(its:ite) :: coefm -! - real, dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & - ulow, rulow, bnv, oa, ol, rhobar, & - dtfac, brvf, xlinv, delks,delks1, & - zlowtop,cleff - real, dimension(its:ite,kts:kte+1) :: taup - real, dimension(its:ite,kts:kte-1) :: velco - real, dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj -! - integer, dimension(its:ite) :: kbl, klowtop - integer, parameter :: mdir=8 - integer, dimension(mdir) :: nwdir - data nwdir/6,7,5,8,2,3,1,4/ -! -! variables for flow-blocking drag -! - real, parameter :: frmax = 10. - real, parameter :: olmin = 1.0e-5 - real, parameter :: odmin = 0.1 - real, parameter :: odmax = 10. -! - real :: fbdcd - real :: zblk, tautem - real :: fbdpe, fbdke - real, dimension(its:ite) :: delx, dely - real, dimension(its:ite,4) :: dxy4, dxy4p - real, dimension(4) :: ol4p - real, dimension(its:ite) :: dxy, dxyp, olp, od - real, dimension(its:ite,kts:kte+1) :: taufb -! - integer, dimension(its:ite) :: komax - integer :: kblk -!------------------------------------------------------------------------------- -! -! constants -! - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi_) -! -! calculate length of grid for flow-blocking drag -! - delx(its:ite) = dxmeter - dely(its:ite) = dxmeter - dxy4(its:ite,1) = delx(its:ite) - dxy4(its:ite,2) = dely(its:ite) - dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) - dxy4(its:ite,4) = dxy4(its:ite,3) - dxy4p(its:ite,1) = dxy4(its:ite,2) - dxy4p(its:ite,2) = dxy4(its:ite,1) - dxy4p(its:ite,3) = dxy4(its:ite,4) - dxy4p(its:ite,4) = dxy4(its:ite,3) -! - cleff(its:ite) = dxmeter -! -! initialize arrays -! - ldrag = .false. ; icrilv = .false. ; flag = .true. -! - klowtop = 0 ; kbl = 0 -! - dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. - ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. - oa = 0. ; ol = 0. ; taub = 0. -! - usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. - taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. -! - dtfac = 1.0 ; xlinv = 1.0/xl -! -! initialize arrays for flow-blocking drag -! - komax = 0 - taufb = 0.0 -! - do k = kts,kte - do i = its,ite - vtj(i,k) = t1(i,k) * (1.+fv_*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) ! density kg/m**3 - enddo - enddo -! - do i = its,ite - zlowtop(i) = 2. * var(i) - enddo -! - do i = its,ite - kloop1(i) = .true. - enddo -! - do k = kts+1,kte - do i = its,ite - if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then - klowtop(i) = k+1 - kloop1(i) = .false. - endif - enddo - enddo -! - do i = its,ite -! -! determine reference level: 2*var -! - kbl(i) = klowtop(i) - kbl(i) = max(min(kbl(i),kpblmax),kpblmin) - enddo -! -! determine the level of maximum orographic height -! - komax(:) = kbl(:) -! - do i = its,ite - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,ite - if (k.lt.kbl(i)) then - rcsks = del(i,k) * delks(i) - rdelks = del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean - rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho mean - endif - enddo - enddo -! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! - do i = its,ite - 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) -! -! compute orographic width along (ol) and perpendicular (olp) the wind direction -! - ol4p(1) = ol4(i,2) - ol4p(2) = ol4(i,1) - ol4p(3) = ol4(i,4) - ol4p(4) = ol4(i,3) - olp(i) = ol4p(mod(nwd-1,4)+1) -! -! compute orographic direction (horizontal orographic aspect ratio) -! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) -! -! compute length of grid in the along(dxy) and cross(dxyp) wind directions -! - dxy(i) = dxy4(i,MOD(nwd-1,4)+1) - dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) - enddo -! -! saving richardson number in usqj for migwdi -! - do k = kts,kte-1 - do i = its,ite - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g_*(g_/cp_+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - enddo - enddo -! -! compute the "low level" or 1/3 wind magnitude (m/s) -! - do i = its,ite - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) - rulow(i) = 1./ulow(i) - enddo -! - do k = kts,kte-1 - do i = its,ite - velco(i,k) = 0.5 * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps - endif - enddo - enddo -! -! no drag when critical level in the base layer -! - do i = its,ite - ldrag(i) = velco(i,1).le.0. - enddo -! -! no drag when velco.lt.0 -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo - enddo -! -! the low level weighted average ri is stored in usqj(1,1; im) -! the low level weighted average n**2 is stored in bnv2(1,1; im) -! this is called bnvl2 in phy_gwd_alpert_sub not bnv2 -! rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks - endif - enddo - enddo -! - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 - enddo -! -! set all ri low level values to the low level value -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo - enddo -! - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * var(i) * od(i) - fr(i) = min(fr(i),frmax) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif - enddo -! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt -! - do i = its,ite - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) - coefm(i) = (1. + ol(i)) ** (oa(i)+1.) - xlinv(i) = coefm(i) / cleff(i) - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * rhobar(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - enddo -! -! now compute vertical structure of the stress. -! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo -! - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite -! -! unstablelayer if ri < ric -! unstable layer if upper air vel comp along surf vel <=0 (crit lay) -! at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & - .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo -! - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then - temv = 1.0 / velco(i,k) - tem1 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(i,k))*brvf(i)*velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv -! -! rim is the minimum-richardson number by shutts (1985) -! - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) -! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions -! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo - enddo -! - if (lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif - do i = its,ite - if (.not.ldrag(i)) then -! -! determine the height of flow-blocking layer -! - kblk = 0 - fbdpe = 0.0 - fbdke = 0.0 - do k = kte, kpblmin, -1 - if (kblk.eq.0 .and. k.le.kbl(i)) then - fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & - *del(i,k)/g_/rho(i,k) - fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) -! -! apply flow-blocking drag when fbdpe >= fbdke -! - if (fbdpe.ge.fbdke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - endif - endif +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + integer,intent(in):: itimestep + + integer,intent(in),dimension(ims:ime,jms:jme):: kpbl2d + + real(kind=kind_phys),intent(in):: dt,cp,g,rd,rv,ep1,pi + real(kind=kind_phys),intent(in),optional:: p_top + + real(kind=kind_phys),intent(in),dimension(kms:kme),optional:: & + znu, & + znw + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + var2d, & + oc12d, & + oa2d1,oa2d2,oa2d3,oa2d4, & + ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + qv3d, & + p3d, & + pi3d, & + t3d, & + u3d, & + v3d, & + z + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + p3di + +!--- output arguments: + character(len=*),intent(out):: errmsg + + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + dusfcg, & + dvsfcg + + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + dtaux3d, & + dtauy3d + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + rublten, & + rvblten + +!--- local variables and arrays: + integer:: i,j,k + + real(kind=kind_phys),dimension(its:ite):: & + var2d_hv,oc12d_hv,dx_hv,sina_hv,cosa_hv + real(kind=kind_phys),dimension(its:ite):: & + oa2d1_hv,oa2d2_hv,oa2d3_hv,oa2d4_hv,ol2d1_hv,ol2d2_hv,ol2d3_hv,ol2d4_hv + real(kind=kind_phys),dimension(its:ite):: & + dusfcg_hv,dvsfcg_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + u3d_hv,v3d_hv,t3d_hv,qv3d_hv,pi3d_hv,p3d_hv,z_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + rublten_hv,rvblten_hv,dtaux3d_hv,dtauy3d_hv + + real(kind=kind_phys),dimension(its:ite,kms:kme):: & + p3di_hv + +!----------------------------------------------------------------------------------------------------------------- + +! Outer j-loop. Allows consistency between WRF and MPAS in the driver. + + do j = jts,jte + + ! All variables for gwdo2d are tile-sized and have only a single + ! horizontal dimension. The _hv suffix refers to "horizontal vertical", + ! a reminder that there is a single horizontal index. Yes, we know that + ! variables that have only a horizontal index are not *really* _hv. + + ! All of the following 3d and 2d variables are declared intent(in) in the + ! gwdo2d subroutine, so there is no need to put the updated values back + ! from the temporary arrays back into the original arrays. + + ! Variables that are INTENT(IN) or INTENT(INOUT) + + ! 3d, interface levels: + do k = kts,kte+1 + do i = its,ite + p3di_hv(i,k) = p3di(i,k,j) enddo - if (kblk.ne.0) then -! -! compute flow-blocking stress -! - fbdcd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter**2*fbdcd*dxyp(i) & - *olp(i)*zblk*ulow(i)**2 - tautem = taufb(i,kts)/real(kblk-kts) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo -! -! sum orographic GW stress and flow-blocking stress -! - taup(i,:) = taup(i,:) + taufb(i,:) - endif - endif - enddo -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! - do k = kts,kte - do i = its,ite - taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * g_ / del(i,k) - enddo - enddo -! -! if the gravity wave drag would force a critical line -! in the lower ksmm1 layers during the next deltim timestep, -! then only apply drag until that critical line is reached. -! - do k = kts,kpblmax-1 - do i = its,ite - if (k .le. kbl(i)) then - if (taud(i,k).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k)/(deltim*taud(i,k)))) - endif - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - enddo -! - do k = kts,kte - do i = its,ite - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) - dtaux2d(i,k) = dtaux - dtauy2d(i,k) = dtauy - dudt(i,k) = dtaux + dudt(i,k) - dvdt(i,k) = dtauy + dvdt(i,k) - dusfc(i) = dusfc(i) + dtaux * del(i,k) - dvsfc(i) = dvsfc(i) + dtauy * del(i,k) - enddo - enddo -! - do i = its,ite - dusfc(i) = (-1./g_) * dusfc(i) - dvsfc(i) = (-1./g_) * dvsfc(i) - enddo -! - return - end subroutine gwdo2d -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- + enddo + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten_hv(i,k) = rublten(i,k,j) + rvblten_hv(i,k) = rvblten(i,k,j) + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + z_hv(i,k) = z(i,k,j) + enddo + enddo + + ! 2d: + do i = its,ite + dx_hv(i) = dx(i,j) + var2d_hv(i) = var2d(i,j) + oc12d_hv(i) = oc12d(i,j) + sina_hv(i) = sina(i,j) + cosa_hv(i) = cosa(i,j) + oa2d1_hv(i) = oa2d1(i,j) + oa2d2_hv(i) = oa2d2(i,j) + oa2d3_hv(i) = oa2d3(i,j) + oa2d4_hv(i) = oa2d4(i,j) + ol2d1_hv(i) = ol2d1(i,j) + ol2d2_hv(i) = ol2d2(i,j) + ol2d3_hv(i) = ol2d3(i,j) + ol2d4_hv(i) = ol2d4(i,j) + enddo + + call bl_gwdo_run(sina=sina_hv,cosa=cosa_hv & + ,rublten=rublten_hv,rvblten=rvblten_hv & + ,dtaux3d=dtaux3d_hv,dtauy3d=dtauy3d_hv & + ,dusfcg=dusfcg_hv,dvsfcg=dvsfcg_hv & + ,uproj=u3d_hv,vproj=v3d_hv & + ,t1=t3d_hv,q1=qv3d_hv & + ,prsi=p3di_hv & + ,prsl=p3d_hv,prslk=pi3d_hv & + ,zl=z_hv & + ,var=var2d_hv,oc1=oc12d_hv & + ,oa2d1=oa2d1_hv, oa2d2=oa2d2_hv & + ,oa2d3=oa2d3_hv, oa2d4=oa2d4_hv & + ,ol2d1=ol2d1_hv, ol2d2=ol2d2_hv & + ,ol2d3=ol2d3_hv, ol2d4=ol2d4_hv & + ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & + ,dxmeter=dx_hv,deltim=dt & + ,its=its,ite=ite,kte=kte,kme=kte+1 & + ,errmsg=errmsg,errflg=errflg) + + ! Variables that are INTENT(OUT) or INTENT(INOUT): + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) + dtaux3d(i,k,j) = dtaux3d_hv(i,k) + dtauy3d(i,k,j) = dtauy3d_hv(i,k) + enddo + enddo + + ! 2d: + do i = its,ite + dusfcg(i,j) = dusfcg_hv(i) + dvsfcg(i,j) = dvsfcg_hv(i) + enddo + + enddo ! Outer J-loop + + end subroutine gwdo + +!================================================================================================================= end module module_bl_gwdo +!================================================================================================================= diff --git a/phys/module_bl_mynn.F b/phys/module_bl_mynn.F index 9eb0e65521..fca1f33a31 100644 --- a/phys/module_bl_mynn.F +++ b/phys/module_bl_mynn.F @@ -232,7 +232,7 @@ ! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. -! v4.5.2 / CCPP +! v4.6 / CCPP ! Some code optimization. Removed many conditions from loops. Redesigned the mass- ! flux scheme to use 8 plumes instead of a variable n plumes. This results in ! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. @@ -242,6 +242,7 @@ ! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This ! results in a change in the pre-radiation code to no longer multiply mixing ratios ! by cloud fractions. +! Bug fix for the momentum transport. ! Lots of code cleanup: removal of test code, comments, changing text case, etc. ! Many misc tuning/tweaks. ! @@ -1114,7 +1115,7 @@ SUBROUTINE mynn_bl_driver( & !! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. if (bl_mynn_topdown.eq.1) then - call topdown_cloudrad(kts,kte,dz1,zw, & + call topdown_cloudrad(kts,kte,dz1,zw,fltv, & &xland(i),kpbl(i),PBLH(i), & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & &cldfra_bl1D,rthraten(i,:), & @@ -2001,9 +2002,9 @@ SUBROUTINE mym_length ( & uonset= 15. wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) cns = 2.7 !was 3.5 - alp1 = 0.22 + alp1 = 0.23 alp2 = 0.3 - alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2059,12 +2060,12 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.001) + bv = max( sqrt( gtr*dtv(k) ), 0.0001) elb = MAX(alp2*qkw(k), & & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.80 * qkw(k)/bv + elf = 1.0 * qkw(k)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 @@ -2084,8 +2085,10 @@ SUBROUTINE mym_length ( & !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + !try squared-blending - but take out elb (makes it underdiffusive) + !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + el(k) = sqrt( els**2/(1. + (els**2/elt**2))) + el(k) = min(el(k), elb) el(k) = MIN (el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt @@ -3633,13 +3636,13 @@ SUBROUTINE mym_condensation (kts,kte, & real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & - &ls,wt,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc real(kind_phys), parameter :: qpct_sfc=0.025 real(kind_phys), parameter :: qpct_pbl=0.030 real(kind_phys), parameter :: qpct_trp=0.040 real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 - real(kind_phys), parameter :: rhmax =1.01 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 integer :: i,j,k real(kind_phys):: erf @@ -3864,25 +3867,18 @@ SUBROUTINE mym_condensation (kts,kte, & !Add condition for falling/settling into low-RH layers, so at least !some cloud fraction is applied for all qc, qs, and qi. rh_hack= rh(k) + wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) - if (qi(k)>1.e-9 .and. zagl .gt. pblh2) then - rh_hack =min(rhmax, rhcrit + 0.07*(9.0 + log10(qi(k)))) + if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif - !ensure adequate RH & q1 when qc is at least 1e-6 - if (qc(k)>1.e-6) then - rh_hack =min(rhmax, rhcrit + 0.09*(6.0 + log10(qc(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - !ensure adequate RH & q1 when qs is at least 1e-8 (above the PBLH) - if (qs(k)>1.e-8 .and. zagl .gt. pblh2) then - rh_hack =min(rhmax, rhcrit + 0.07*(8.0 + log10(qs(k)))) + !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) + if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) @@ -3994,7 +3990,7 @@ SUBROUTINE mym_condensation (kts,kte, & fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.35) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) enddo @@ -4182,38 +4178,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! sub_u(k)*delt + det_u(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - & - & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & -! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & - & sub_u(k)*delt + det_u(k)*delt - ENDDO + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & + & + sub_u(k)*delt + det_u(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & + & + sub_u(k)*delt + det_u(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4248,37 +4239,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! sub_v(k)*delt + det_v(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + & - & sub_v(k)*delt + det_v(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & -! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & - & sub_v(k)*delt + det_v(k)*delt - ENDDO + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & + & + sub_v(k)*delt + det_v(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & + & + sub_v(k)*delt + det_v(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -7637,7 +7624,8 @@ FUNCTION phih(zet) END FUNCTION phih ! ================================================================== - SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & + SUBROUTINE topdown_cloudrad(kts,kte, & + &dz1,zw,fltv,xland,kpbl,PBLH, & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & &cldfra_bl1D,rthraten, & &maxKHtopdown,KHtopdown,TKEprodTD ) @@ -7648,7 +7636,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D real(kind_phys), dimension(kts:kte), intent(in) :: rthraten real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: pblh + real(kind_phys), intent(in) :: pblh,fltv real(kind_phys), intent(in) :: xland integer , intent(in) :: kpbl !output @@ -7656,7 +7644,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD !local real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent - real(kind_phys) :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 + real(kind_phys) :: bfx0,wm2,wm3,bfxpbl,dthvx,tmp1 real(kind_phys) :: temps,templ,zl1,wstar3_2 real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 @@ -7720,15 +7708,15 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & bfx0 = max(radsum/rho1(k)/cp,0.) else ! LAND radsum=MIN(0.25*radsum,30.0)!practically turn off over land - bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) + bfx0 = max(radsum/rho1(k)/cp - max(fltv,0.0),0.) endif !entrainment from PBL top thermals wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) - wm2 = wm2 + wm3**h2 + wm2 = wm2 + wm3**twothirds bfxpbl = - ent_eff * bfx0 dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) + we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds)) DO kk = kts,kpbl+3 !Analytic vertical profile @@ -7736,7 +7724,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 !Calculate an eddy diffusivity profile (not used at the moment) - wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**onethird !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0 KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac KHtopdown(kk) = MAX(KHtopdown(kk),0.0) diff --git a/phys/module_bl_ysu.F b/phys/module_bl_ysu.F index b2584eaa96..403532e094 100644 --- a/phys/module_bl_ysu.F +++ b/phys/module_bl_ysu.F @@ -1,23 +1,22 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 !================================================================================================================= -!module_bl_ysu.F was modified to accomodate both the WRF and MPAS models / 2018-12-7 + module module_bl_ysu + use ccpp_kind_types,only: kind_phys + use bl_ysu + + + implicit none + private + public:: ysu + + + contains + + !================================================================================================================= -!WRF:model_layer:physics -! -! -! -! -! -! -! -module module_bl_ysu -contains -! -! -!------------------------------------------------------------------------------- -! - subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & + subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rublten,rvblten,rthblten, & - rqvblten,rqcblten,rqiblten,flag_qi, & + rqvblten,rqcblten,rqiblten,flag_qc,flag_qi, & cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & dz8w,psfc, & znt,ust,hpbl,psim,psih, & @@ -39,11 +38,10 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - !optional - regime & + errmsg,errflg & ) !------------------------------------------------------------------------------- - implicit none + implicit none !------------------------------------------------------------------------------- !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) @@ -97,6 +95,23 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- ep1 constant for virtual temperature (r_v/r_d - 1) !-- ep2 constant for specific humidity calculation !-- karman von karman constant +!-- idiff diff3d BEP/BEM+BEM diffusion flag +!-- flag_bep flag to use BEP/BEP+BEM +!-- frc_urb2d urban fraction +!-- a_u_bep BEP/BEP+BEM implicit component u-mom +!-- a_v_bep BEP/BEP+BEM implicit component v-mom +!-- a_t_bep BEP/BEP+BEM implicit component pot. temp. +!-- a_q_bep BEP/BEP+BEM implicit component vapor mixing ratio +!-- a_e_bep BEP/BEP+BEM implicit component TKE +!-- b_u_bep BEP/BEP+BEM explicit component u-mom +!-- b_v_bep BEP/BEP+BEM explicit component v-mom +!-- b_t_bep BEP/BEP+BEM explicit component pot.temp. +!-- b_q_bep BEP/BEP+BEM explicit component vapor mixing ratio +!-- b_e_bep BEP/BEP+BEM explicit component TKE +!-- dlg_bep Height above ground Martilli et al. (2002) Eq. 24 +!-- dl_u_bep modified length scale Martilli et al. (2002) Eq. 22 +!-- sf_bep fraction of vertical surface not occupied by buildings +!-- vl_bep volume fraction of grid cell not occupied by buildings !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -115,27 +130,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile -!-- idiff diff3d BEP/BEM+BEM diffusion flag -!-- flag_bep flag to use BEP/BEP+BEM -!-- frc_urb2d urban fraction -!-- a_u_bep BEP/BEP+BEM implicit component u-mom -!-- a_v_bep BEP/BEP+BEM implicit component v-mom -!-- a_t_bep BEP/BEP+BEM implicit component pot. temp. -!-- a_q_bep BEP/BEP+BEM implicit component vapor mixing ratio -!-- a_e_bep BEP/BEP+BEM implicit component TKE -!-- b_u_bep BEP/BEP+BEM explicit component u-mom -!-- b_v_bep BEP/BEP+BEM explicit component v-mom -!-- b_t_bep BEP/BEP+BEM explicit component pot.temp. -!-- b_q_bep BEP/BEP+BEM explicit component vapor mixing ratio -!-- b_e_bep BEP/BEP+BEM explicit component TKE -!-- dlg_bep Height above ground Martilli et al. (2002) Eq. 24 -!-- dl_u_bep modified length scale Martilli et al. (2002) Eq. 22 -!-- sf_bep fraction of vertical surface not occupied by buildings -!-- vl_bep volume fraction of grid cell not occupied by buildings !------------------------------------------------------------------------------- ! - integer,parameter :: ndiff = 3 - real,parameter :: rcl = 1.0 ! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -143,70 +139,76 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, intent(in) :: ysu_topdown_pblmix ! - real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv ! - real, intent(in ) :: ep1,ep2,karman + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: qv3d, & qc3d, & qi3d, & p3d, & pi3d, & - th3d, & t3d, & dz8w, & rthraten - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: p3di ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: rublten, & rvblten, & rthblten, & rqvblten, & - rqcblten + rqcblten, & + rqiblten ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: exch_h, & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: exch_h, & exch_m - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: wstar - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: delta - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: wstar + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: delta + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(inout) :: u10, & v10 - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: uoce, & voce ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & hfx, & qfx, & br, & psfc - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: & psim, & psih - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: znt, & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(in ) :: znt, & ust, & - hpbl, & wspd + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: hpbl ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: u3d, & v3d ! integer, dimension( ims:ime, jms:jme ) , & intent(out ) :: kpbl2d - logical, intent(in) :: flag_qi - integer, intent(in) :: idiff - logical, intent(in) :: flag_bep - real,dimension(ims:ime,kms:kme,jms:jme),intent(in) :: a_u_bep, & +! + logical, intent(in) :: flag_qc, & + flag_qi +! + integer, intent(in) :: idiff + logical, intent(in) :: flag_bep + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + optional , & + intent(in) :: a_u_bep, & a_v_bep,a_t_bep, & a_e_bep,b_u_bep, & a_q_bep,b_q_bep, & @@ -214,1700 +216,263 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & b_e_bep,dlg_bep, & dl_u_bep, & vl_bep,sf_bep - real, dimension(ims:ime,jms:jme),intent(in) :: frc_urb2d -! -!optional -! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(inout) :: regime -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension(ims:ime,jms:jme) , & optional , & - intent(inout) :: rqiblten + intent(in) :: frc_urb2d ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & optional , & intent(in ) :: ctopo, & ctopo2 +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !local integer :: i,j,k - real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, & - qv2d - real, dimension( its:ite, kts:kte ) :: pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite ) :: & - dusfc, & - dvsfc, & - dtsfc, & - dqsfc - real,dimension(its:ite,kts:kte,jts:jte) :: a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e, & - a_q,b_q,dlg,dl_u,sfk,vlk - real,dimension(its:ite,jts:jte) :: frcurb - real :: bepswitch ! 0 if not using bep or bep+bem, 1 if using -! - qv2d(its:ite,:) = 0.0 -! - bepswitch = 0.0 - a_u(:,:,:)=0.0 - a_v(:,:,:)=0.0 - a_t(:,:,:)=0.0 - a_q(:,:,:)=0.0 - a_e(:,:,:)=0.0 - b_u(:,:,:)=0.0 - b_v(:,:,:)=0.0 - b_t(:,:,:)=0.0 - b_q(:,:,:)=0.0 - b_e(:,:,:)=0.0 - sfk(:,:,:)=1.0 - vlk(:,:,:)=1.0 - dl_u(:,:,:)=0.0 - dlg(:,:,:)=0.0 - frcurb(:,:)=0.0 - do j = jts,jte - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo +!temporary allocation of local chemical species and/or passive tracers that are vertically- +!mixed in subroutine bl_ysu_run: + logical:: l_topdown_pblmix - do k = kts,kte - do i = its,ite - qv2d(i,k) = qv3d(i,k,j) - qv2d(i,k+kte) = qc3d(i,k,j) - if(flag_qi) qv2d(i,k+kte+kte) = qi3d(i,k,j) - enddo - enddo + integer, parameter :: nmix = 0 + integer :: n - if(flag_bep) then - bepswitch=1.0 - do k=kts,kte - do i=its,ite - a_u(i,k,j)=a_u_bep(i,k,j) - a_v(i,k,j)=a_v_bep(i,k,j) - a_t(i,k,j)=a_t_bep(i,k,j) - a_q(i,k,j)=a_q_bep(i,k,j) - a_e(i,k,j)=a_e_bep(i,k,j) - b_u(i,k,j)=b_u_bep(i,k,j) - b_v(i,k,j)=b_v_bep(i,k,j) - b_t(i,k,j)=b_t_bep(i,k,j) - b_q(i,k,j)=b_q_bep(i,k,j) - b_e(i,k,j)=b_e_bep(i,k,j) - sfk(i,k,j)=sf_bep(i,k,j) - vlk(i,k,j)=vl_bep(i,k,j) - dl_u(i,k,j)=dl_u_bep(i,k,j) - dlg(i,k,j)=dlg_bep(i,k,j) - frcurb(i,j)=frc_urb2d(i,j) - enddo - enddo - endif -! - call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j) & - ,tx=t3d(ims,kms,j) & - ,qx=qv2d(its,kts) & - ,p2d=pdh(its,kts),p2di=pdhi(its,kts) & - ,pi2d=pi3d(ims,kms,j) & - ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j) & - ,ttnp=rthblten(ims,kms,j),qtnp=rqvbl2dt(its,kts),ndiff=ndiff & - ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & - ,xlv=xlv,rv=rv & - ,ep1=ep1,ep2=ep2,karman=karman & - ,dz8w2d=dz8w(ims,kms,j) & - ,psfcpa=psfc(ims,j),znt=znt(ims,j),ust=ust(ims,j) & - ,hpbl=hpbl(ims,j) & - ,regime=regime(ims,j),psim=psim(ims,j) & - ,psih=psih(ims,j),xland=xland(ims,j) & - ,hfx=hfx(ims,j),qfx=qfx(ims,j) & - ,wspd=wspd(ims,j),br=br(ims,j) & - ,dusfc=dusfc,dvsfc=dvsfc,dtsfc=dtsfc,dqsfc=dqsfc & - ,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j) & - ,exch_hx=exch_h(ims,kms,j) & - ,exch_mx=exch_m(ims,kms,j) & - ,wstar=wstar(ims,j) & - ,delta=delta(ims,j) & - ,u10=u10(ims,j),v10=v10(ims,j) & - ,uox=uoce(ims,j),vox=voce(ims,j) & - ,rthraten=rthraten(ims,kms,j),p2diORG=p3di(ims,kms,j) & - ,ysu_topdown_pblmix=ysu_topdown_pblmix & - ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) & - ,a_u2d=a_u(its,kts,j), a_v2d=a_v(its,kts,j) & - ,a_t2d=a_t(its,kts,j), a_q2d=a_q(its,kts,j) & - ,b_u2d=b_u(its,kts,j), b_v2d=b_v(its,kts,j) & - ,b_t2d=b_t(its,kts,j), b_q2d=b_q(its,kts,j) & - ,b_e2d=b_e(its,kts,j), a_e2d=a_e(its,kts,j) & - ,sfk2d=sfk(its,kts,j), vlk2d=vlk(its,kts,j) & - ,dlu2d=dl_u(its,kts,j), dlg2d=dlg(its,kts,j) & - ,frc_urb1d=frcurb(its,j), bepswitch=bepswitch & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) -! - do k = kts,kte - do i = its,ite - rthblten(i,k,j) = rthblten(i,k,j)/pi3d(i,k,j) - rqvblten(i,k,j) = rqvbl2dt(i,k) - rqcblten(i,k,j) = rqvbl2dt(i,k+kte) - if(flag_qi) rqiblten(i,k,j) = rqvbl2dt(i,k+kte+kte) - enddo - enddo -! - enddo -! - end subroutine ysu -! -!------------------------------------------------------------------------------- -! - subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & - utnp,vtnp,ttnp,qtnp,ndiff, & - cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & - dz8w2d,psfcpa, & - znt,ust,hpbl,psim,psih, & - xland,hfx,qfx,wspd,br, & - dusfc,dvsfc,dtsfc,dqsfc, & - dt,rcl,kpbl1d, & - exch_hx,exch_mx, & - wstar,delta, & - u10,v10, & - uox,vox, & - rthraten,p2diORG, & - ysu_topdown_pblmix, & - ctopo,ctopo2, & - a_u2d, a_v2d, a_t2d, a_q2d, & - b_u2d, b_v2d, b_t2d, b_q2d, & - b_e2d, a_e2d, sfk2d, vlk2d, & - dlu2d, dlg2d, & - frc_urb1d, bepswitch, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - !optional - regime & - ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! -! this code is a revised vertical diffusion package ("ysupbl") -! with a nonlocal turbulent mixing in the pbl after "mrfpbl". -! the ysupbl (hong et al. 2006) is based on the study of noh -! et al.(2003) and accumulated realism of the behavior of the -! troen and mahrt (1986) concept implemented by hong and pan(1996). -! the major ingredient of the ysupbl is the inclusion of an explicit -! treatment of the entrainment processes at the entrainment layer. -! this routine uses an implicit approach for vertical flux -! divergence and does not require "miter" timesteps. -! it includes vertical diffusion in the stable atmosphere -! and moist vertical diffusion in clouds. -! -! mrfpbl: -! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) -! fall 1996 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! further modifications : -! an enhanced stable layer mixing, april 2008 -! ==> increase pbl height when sfc is stable (hong 2010) -! pressure-level diffusion, april 2009 -! ==> negligible differences -! implicit forcing for momentum with clean up, july 2009 -! ==> prevents model blowup when sfc layer is too low -! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 -! ==> prevents model blowup when delz is extremely large -! revised prandtl number at surface, peggy lemone, feb 2010 -! ==> increase kh, decrease mixing due to counter-gradient term -! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 -! ==> reduce the thermal strength when z1 < 0.1 h -! revised prandtl number for free convection, dudhia, mar 2012 -! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced -! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 -! ==> weaker mixing when stable, and les resolution in vertical -! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 -! ==> consider thermal z0 when differs from mechanical z0 -! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 -! ==> wscale becomes small with height, and less mixing in stable bl -! revision in background diffusion (kzo), jan 2016 -! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for -! internal wave mixing of large et al. (1994), songyou hong, feb 2016 -! ==> alleviate superious excessive mixing when delz is large -! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 -! -! references: -! -! hendricks, knievel, and wang (2020), j. appl. meteor. clim. -! hong (2010) quart. j. roy. met. soc -! hong, noh, and dudhia (2006), mon. wea. rev. -! hong and pan (1996), mon. wea. rev. -! noh, chun, hong, and raasch (2003), boundary layer met. -! troen and mahrt (1986), boundary layer met. -! -!------------------------------------------------------------------------------- -! - real,parameter :: xkzminm = 0.1,xkzminh = 0.01 - real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. - real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. - real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 - real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 - real,parameter :: phifac = 8.,sfcfrac = 0.1 - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333333, h2 = 0.6666667 - real,parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. - real,parameter :: tmin=1.e-2 - real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 - real,parameter :: xka = 2.4e-5 - integer,parameter :: imvdif = 1 -! - integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - j,ndiff + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: qmix + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: rqmixblten - integer, intent(in) :: ysu_topdown_pblmix -! - real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv -! - real, intent(in ) :: ep1,ep2,karman -! - real, dimension( ims:ime, kms:kme ), & - intent(in) :: dz8w2d, & - pi2d, & - p2diorg -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: tx - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(in ) :: qx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: utnp, & - vtnp, & - ttnp - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(inout) :: qtnp -! - real, dimension( its:ite, kts:kte+1 ) , & - intent(in ) :: p2di -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: p2d -! - real, dimension( ims:ime ) , & - intent(inout) :: ust, & - hpbl, & - znt - real, dimension( ims:ime ) , & - intent(in ) :: xland, & - hfx, & - qfx -! - real, dimension( ims:ime ), intent(inout) :: wspd - real, dimension( ims:ime ), intent(in ) :: br -! - real, dimension( ims:ime ), intent(in ) :: psim, & - psih -! - real, dimension( ims:ime ), intent(in ) :: psfcpa - integer, dimension( ims:ime ), intent(out ) :: kpbl1d -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: ux, & - vx, & - rthraten - real, dimension( ims:ime ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 - real, dimension( ims:ime ) , & - optional , & - intent(inout) :: regime -! -! local vars -! - real, dimension( its:ite, kts:kte ), & - intent(in) :: a_u2d, & - a_v2d, & - a_t2d, & - a_q2d, & - b_u2d, & - b_v2d, & - b_t2d, & - b_q2d, & - b_e2d, & - a_e2d, & - sfk2d, & - vlk2d, & - dlu2d, & - dlg2d - - real, dimension( its:ite ), & - intent(in) :: frc_urb1d - real :: bepswitch - real, dimension( its:ite ) :: hol - real, dimension( its:ite, kts:kte+1 ) :: zq -! - real, dimension( its:ite, kts:kte ) :: & - thx,thvx,thlix, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za -! - real, dimension( its:ite ) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - prpbl, & - wspd1,thermalli -! - real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - xkzq, & - zfac, & - rhox2, & - hgamt2, & - ad1, adm -! -!jdf added exch_hx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: exch_hx, & - exch_mx -! - real, dimension( ims:ime ) , & - intent(inout) :: u10, & - v10 - real, dimension( ims:ime ) , & - intent(in ) :: uox, & - vox - real, dimension( its:ite ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 - integer, dimension( its:ite ) :: kpbl,kpblold -! - logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable, & - cloudflg - - logical :: definebrup -! - integer :: n,i,k,l,ic,is,kk - integer :: klpbl, ktrace1, ktrace2, ktrace3 -! -! - real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 - real :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri - real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz - real :: utend,vtend,ttend,qtend - real :: dtstep,govrthv - real :: cont, conq, conw, conwrc -! + ! Local tile-sized arrays for contiguous data for bl_ysu_run call. - real, dimension( its:ite, kts:kte ) :: wscalek,wscalek2 - real, dimension( ims:ime ) :: wstar - real, dimension( ims:ime ) :: delta - real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & - zfacent,entfac - real, dimension( its:ite ) :: ust3, & - wstar3, & - wstar3_2, & - hgamu,hgamv, & - wm2, we, & - bfxpbl, & - hfxpbl,qfxpbl, & - ufxpbl,vfxpbl, & - dthvx - real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & - dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & - prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & - rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv -!topo-corr - real, dimension( ims:ime, kms:kme ) :: fric, & - tke_ysu,& - el_ysu,& - shear_ysu,& - buoy_ysu - real, dimension( ims:ime ) :: pblh_ysu,& - vconvfx -! -!------------------------------------------------------------------------------- -! - klpbl = kte -! - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! -! k-start index for tracer diffusion -! - ktrace1 = 0 - ktrace2 = 0 + kte - ktrace3 = 0 + kte*2 -! - do k = kts,kte - do i = its,ite - thx(i,k) = tx(i,k)/pi2d(i,k) - thlix(i,k) = (tx(i,k)-xlv*qx(i,ktrace2+k)/cp-2.834E6*qx(i,ktrace3+k)/cp)/pi2d(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - tvcon = (1.+ep1*qx(i,k)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - do i = its,ite - tvcon = (1.+ep1*qx(i,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - enddo -! -!-----compute the height of full- and half-sigma levels above ground -! level, and the layer thicknesses. -! - do i = its,ite - zq(i,1) = 0. - enddo -! - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz8w2d(i,k)+zq(i,k) - tvcon = (1.+ep1*qx(i,k)) - rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) - enddo - enddo -! - do k = kts,kte - do i = its,ite - za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - enddo - enddo -! - do i = its,ite - dza(i,1) = za(i,1) - enddo -! - do k = kts+1,kte - do i = its,ite - dza(i,k) = za(i,k)-za(i,k-1) - enddo - enddo -! -! -!-----initialize vertical tendencies and -! - utnp(its:ite,:) = 0. - vtnp(its:ite,:) = 0. - ttnp(its:ite,:) = 0. - qtnp(its:ite,:) = 0. -! - do i = its,ite - wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 - enddo -! -!---- compute vertical diffusion -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! compute preliminary variables -! - dtstep = dt - dt2 = 2.*dtstep - rdt = 1./dt2 -! - do i = its,ite - bfxpbl(i) = 0.0 - hfxpbl(i) = 0.0 - qfxpbl(i) = 0.0 - ufxpbl(i) = 0.0 - vfxpbl(i) = 0.0 - hgamu(i) = 0.0 - hgamv(i) = 0.0 - delta(i) = 0.0 - wstar3_2(i) = 0.0 - enddo -! - do k = kts,klpbl - do i = its,ite - wscalek(i,k) = 0.0 - wscalek2(i,k) = 0.0 - enddo - enddo -! - do k = kts,klpbl - do i = its,ite - zfac(i,k) = 0.0 - enddo - enddo - do k = kts,klpbl-1 - do i = its,ite - xkzom(i,k) = xkzminm - xkzoh(i,k) = xkzminh - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do i = its,ite - hgamt(i) = 0. - hgamq(i) = 0. - wscale(i) = 0. - kpbl(i) = 1 - hpbl(i) = zq(i,1) - zl1(i) = za(i,1) - thermal(i)= thvx(i,1) - thermalli(i) = thlix(i,1) - pblflg(i) = .true. - sfcflg(i) = .true. - sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) - if(br(i).gt.0.0) sfcflg(i) = .false. - enddo -! -! compute the first guess of pbl height -! - do i = its,ite - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - enddo -! - do i = its,ite - fm = psim(i) - fh = psih(i) - zol1(i) = max(br(i)*fm*fm/fh,rimin) - if(sfcflg(i))then - zol1(i) = min(zol1(i),-zfmin) - else - zol1(i) = max(zol1(i),zfmin) - endif - hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac - if(sfcflg(i))then - phim(i) = (1.-aphi16*hol1)**(-1./4.) - phih(i) = (1.-aphi16*hol1)**(-1./2.) - bfx0 = max(sflux(i),0.) - hfx0 = max(hfx(i)/rhox(i)/cp,0.) - qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) - wstar3(i) = (govrth(i)*bfx0*hpbl(i)) - wstar(i) = (wstar3(i))**h1 - else - phim(i) = (1.+aphi5*hol1) - phih(i) = phim(i) - wstar(i) = 0. - wstar3(i) = 0. - endif - ust3(i) = ust(i)**3. - wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - enddo -! -! compute the surface variables for pbl height estimation -! under unstable conditions -! - do i = its,ite - if(sfcflg(i).and.sflux(i).gt.0.0)then - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac - thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - else - pblflg(i) = .false. - endif - enddo -! -! enhance the pbl height by considering the thermal -! - do i = its,ite - if(pblflg(i))then - kpbl(i) = 1 - hpbl(i) = zq(i,1) - endif - enddo -! - do i = its,ite - if(pblflg(i))then - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i).and.pblflg(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! -! enhance pbl by theta-li -! - if (ysu_topdown_pblmix.eq.1)then - do i = its,ite - kpblold(i) = kpbl(i) - definebrup=.false. - do k = kpblold(i), kte-1 - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 - stable(i) = bruptmp.ge.brcr(i) - if (definebrup) then - kpbl(i) = k - brup(i) = bruptmp - definebrup=.false. - endif - if (.not.stable(i)) then !overwrite brup brdn values - brdn(i)=bruptmp - definebrup=.true. - pblflg(i)=.true. - endif - enddo - enddo - endif + real(kind=kind_phys), dimension(its:ite,kts:kte,nmix) :: & + qmix_hv , & + rqmixblten_hv - do i = its,ite - if(pblflg(i)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! stable boundary layer -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - brup(i) = br(i) - stable(i) = .false. - else - stable(i) = .true. - endif - enddo -! - do i = its,ite - if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then - wspd10 = u10(i)*u10(i) + v10(i)*v10(i) - wspd10 = sqrt(wspd10) - ross = wspd10 / (cori*znt(i)) - brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) - endif - enddo -! - do i = its,ite - if(.not.stable(i))then - if((xland(i)-1.5).ge.0)then - brcr(i) = brcr_sbro(i) - else - brcr(i) = brcr_sb - endif - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! estimate the entrainment parameters -! - do i = its,ite - cloudflg(i)=.false. - if(pblflg(i)) then - k = kpbl(i) - 1 - wm3 = wstar3(i) + 5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then - if ( kpbl(i) .ge. 2) then - cloudflg(i)=.true. - templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) - temps=templ + ((qx(i,k)+qx(i,ktrace2+k))-rvls)/(cp/xlv + & - ep2*xlv*rvls/(rd*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) - rcldb=max((qx(i,k)+qx(i,ktrace2+k))-rvls,0.) - !entrainment efficiency - dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2)+qx(i,ktrace2+k+2))) & - - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k) +qx(i,ktrace2+k))) - dthvx(i) = max(dthvx(i),0.1) - tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) - ent_eff = 0.2 * 8. * tmp1 +0.2 + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + u3d_hv , & + v3d_hv , & + t3d_hv , & + qv3d_hv , & + qc3d_hv , & + qi3d_hv , & + p3d_hv , & + pi3d_hv , & + rublten_hv , & + rvblten_hv , & + rthblten_hv , & + rqvblten_hv , & + rqcblten_hv , & + rqiblten_hv , & + dz8w_hv , & + exch_h_hv , & + exch_m_hv , & + rthraten_hv - radsum=0. - do kk = 1,kpbl(i)-1 - radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p2diORG(i,kk)-p2diORG(i,kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - enddo - radsum=max(radsum,0.0) + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + a_u_hv , & + a_v_hv , & + a_t_hv , & + a_e_hv , & + b_u_hv , & + a_q_hv , & + b_q_hv , & + b_v_hv , & + b_t_hv , & + b_e_hv , & + dlg_hv , & + dl_u_hv , & + vlk_hv , & + sfk_hv + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: & + p3di_hv - !recompute entrainment from sfc thermals - bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) - bfx0 = max(sflux(i),0.0) - wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + real(kind=kind_phys), dimension(its:ite) :: & + psfc_hv , & + znt_hv , & + ust_hv , & + hpbl_hv , & + psim_hv , & + psih_hv , & + xland_hv , & + hfx_hv , & + qfx_hv , & + wspd_hv , & + br_hv , & + wstar_hv , & + delta_hv , & + u10_hv , & + v10_hv , & + uoce_hv , & + voce_hv , & + ctopo_hv , & + ctopo2_hv - !entrainment from PBL top thermals - bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) - wm2(i) = wm2(i)+wm3**h2 - bfxpbl(i) = - ent_eff * bfx0 - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) - we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + integer, dimension(its:ite) :: & + kpbl2d_hv + real, dimension(its:ite) :: & + frcurb_hv - !wstar3_2 - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) - !recompute hgamt - wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - gamfac = bfac/rhox2(i,k)/wscale(i) - hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) - hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - endif - endif - prpbl(i) = 1.0 - dthx = max(thx(i,k+1)-thx(i,k),tmin) - dqx = min(qx(i,k+1)-qx(i,k),0.0) - hfxpbl(i) = we(i)*dthx - qfxpbl(i) = we(i)*dqx -! - dux = ux(i,k+1)-ux(i,k) - dvx = vx(i,k+1)-vx(i,k) - if(dux.gt.tmin) then - ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) - elseif(dux.lt.-tmin) then - ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) - else - ufxpbl(i) = 0.0 - endif - if(dvx.gt.tmin) then - vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) - elseif(dvx.lt.-tmin) then - vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) - else - vfxpbl(i) = 0.0 - endif - delb = govrth(i)*d3*hpbl(i) - delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) - endif - enddo -! - do k = kts,klpbl - do i = its,ite - if(pblflg(i).and.k.ge.kpbl(i))then - entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. - else - entfac(i,k) = 1.e30 - endif - enddo - enddo -! -! compute diffusion coefficients below pbl -! - do k = kts,klpbl - do i = its,ite - if(k.lt.kpbl(i)) then - zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) - zfacent(i,k) = (1.-zfac(i,k))**3. - wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 - wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 - if(sfcflg(i)) then - prfac = conpr - prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) - prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. - else - prfac = 0. - prfac2 = 0. - prnumfac = 0. - phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) - wscalek(i,k) = ust(i)/phim8z - wscalek(i,k) = max(wscalek(i,k),0.001) - endif - prnum0 = (phih(i)/phim(i)+prfac) - prnum0 = max(min(prnum0,prmax),prmin) - xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & - wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac - !Do not include xkzm at kpbl-1 since it changes entrainment - if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then - xkzm(i,k) = 0.0 - endif - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) - prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzh(i,k) = xkzm(i,k)/prnum - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - endif - enddo - enddo -! -! compute diffusion coefficients over pbl (free atmosphere) -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & - +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & - /(dza(i,k+1)*dza(i,k+1))+1.e-9 - govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) - ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) - if(imvdif.eq.1.and.ndiff.ge.3)then - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.(qx(i & - ,ktrace2+k+1)+qx(i,ktrace3+k+1)).gt.0.01e-3)then -! in cloud - qmean = 0.5*(qx(i,k)+qx(i,k+1)) - tmean = 0.5*(tx(i,k)+tx(i,k+1)) - alph = xlv*qmean/rd/tmean - chi = xlv*xlv*qmean/cp/rv/tmean/tmean - ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) - endif - endif - zk = karman*zq(i,k+1) - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - rl2 = (zk*rlamdz/(rlamdz+zk))**2 - dk = rl2*sqrt(ss) - if(ri.lt.0.)then -! unstable regime - ri = max(ri, rimin) - sri = sqrt(-ri) - xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) - xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) - else -! stable regime - xkzh(i,k) = dk/(1+5.*ri)**2 - prnum = 1.0+2.1*ri - prnum = min(prnum,prmax) - xkzm(i,k) = xkzh(i,k)*prnum - endif -! - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzml(i,k) = xkzm(i,k) - xkzhl(i,k) = xkzh(i,k) - endif - enddo - enddo -! -! compute tridiagonal matrix elements for heat -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f1(i,1) = thx(i,1)-300.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzh(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzt - f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) - xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - f1(i,k+1) = thx(i,k+1)-300. - else - f1(i,k+1) = thx(i,k+1)-300. - endif - tem1 = dsig*xkzh(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! -! add bep/bep+bem forcing for heat if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - enddo - enddo -! - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) -! -! recover tendencies of heat -! - do k = kte,kts,-1 - do i = its,ite - ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) - ttnp(i,k) = ttnp(i,k)+ttend - dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) - enddo - enddo -! -! compute tridiagonal matrix elements for moisture, clouds, and gases -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - enddo - enddo -! - do ic = 1,ndiff - do i = its,ite - do k = kts,kte - f3(i,k,ic) = 0. - enddo - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f3(i,1,1) = qx(i,1)+(1.0-bepswitch)*qfx(i)*g/del(i,1)*dt2 - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do i = its,ite - f3(i,1,ic) = qx(i,1+is) - enddo - enddo - endif -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - xkzq(i,k) = xkzh(i,k) - endif - enddo - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzq(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) - f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq - f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) - xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - f3(i,k+1,1) = qx(i,k+1) - else - f3(i,k+1,1) = qx(i,k+1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) -! exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kts,kte-1 - do i = its,ite - f3(i,k+1,ic) = qx(i,k+1+is) - enddo - enddo - enddo - endif -! -! add bep/bep+bem forcing for water vapor if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_q2d(i,k)*dt2 - f3(i,k,1) = f3(i,k,1) + b_q2d(i,k)*dt2 - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - enddo - enddo -! - do ic = 1,ndiff - do k = kts,kte - do i = its,ite - r3(i,k,ic) = f3(i,k,ic) - enddo - enddo - enddo -! -! solve tridiagonal problem for moisture, clouds, and gases -! - call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) -! -! recover tendencies of heat and moisture -! - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,1)-qx(i,k))*rdt - qtnp(i,k) = qtnp(i,k)+qtend - dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,ic)-qx(i,k+is))*rdt - qtnp(i,k+is) = qtnp(i,k+is)+qtend - enddo - enddo - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i = its,ite - do k = kts,kte - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - f2(i,k) = 0. - enddo - enddo -! -! paj: ctopo=1 if topo_wind=0 (default) -!raquel---paj tke code (could be replaced with shin-hong tke in future - do i = its,ite - do k= kts, kte-1 - shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & - + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) - buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) +!----------------------------------------------------------------------------------------------------------------- - zk = karman*zq(i,k+1) - !over pbl - if (k.ge.kpbl(i)) then - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - else - !in pbl - rlamdz = 150.0 - endif - el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) - tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)+b_e2d(i,k)) - !q2 when q3 positive - if(tke_ysu(i,k).le.0) then - tke_ysu(i,k)=0.0 - else - tke_ysu(i,k)=(tke_ysu(i,k))**0.66 - endif - enddo - !Hybrid pblh of MYNN - !tke is q2 - CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& - & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) -!--- end of paj tke -! compute vconv -! Use Beljaars over land - if (xland(i).lt.1.5) then - fluxc = max(sflux(i),0.0) - vconvc=1. - VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 - else -! for water there is no topo effect so vconv not needed - VCONV = 0. - endif - vconvfx(i) = vconv -!raquel -!ctopo stability correction - fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - if(present(ctopo)) then - vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) - vconvlim = min(vconvnew,1.0) - ad(i,1) = 1.+(1.0-bepswitch*frc_urb1d(i))* & - (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) - & - fric(i,1)*bepswitch*(1-frc_urb1d(i)) - else - ad(i,1) = 1.+(1.0-bepswitch)*fric(i,1) - endif - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzm(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i))then - dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) - dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzu - f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu - f2(i,k) = f2(i,k)+dtodsd*dsdzv - f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzm(i,k) = prpbl(i)*xkzh(i,k) - xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) - xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - else - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - endif - tem1 = dsig*xkzm(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_mx(i,k+1) = xkzm(i,k) - enddo - enddo -! -! add bep/bep+bem forcing for momentum if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad1(i,k) = ad(i,k) - end do - end do - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 - ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 - f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - r2(i,k) = f2(i,k) - enddo - enddo -! -! solve tridiagonal problem for momentum -! - call tridi2n(al,ad,ad1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) -! -! recover tendencies of momentum -! - do k = kte,kts,-1 - do i = its,ite - utend = (f1(i,k)-ux(i,k))*rdt - vtend = (f2(i,k)-vx(i,k))*rdt - utnp(i,k) = utnp(i,k)+utend - vtnp(i,k) = vtnp(i,k)+vtend - dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) - dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) - enddo - enddo -! -! paj: ctopo2=1 if topo_wind=0 (default) -! - do i = its,ite - if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM - u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) - v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) - endif !mchen - enddo -! -!---- end of vertical diffusion -! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo -! - end subroutine ysu2d -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi2n(cl,cm,cm1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm, & - cm1, & - r1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu, & - f1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f1(i,1) = fk*r1(i,1) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./cm1(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo + l_topdown_pblmix = .false. + if(ysu_topdown_pblmix .eq. 1) l_topdown_pblmix = .true. - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm1(i,k)-cl(i,k)*au(i,k-1)) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm1(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do k = n-1,kts,-1 - do i = its,l - f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridi2n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridin_ysu -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & - rqcblten,rqiblten,p_qi,p_first_scalar, & - restart, allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - logical , intent(in) :: restart, allowed_to_read - integer , intent(in) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - integer , intent(in) :: p_qi,p_first_scalar - real , dimension( ims:ime , kms:kme , jms:jme ), intent(out) :: & - rublten, & - rvblten, & - rthblten, & - rqvblten, & - rqcblten, & - rqiblten - integer :: i, j, k, itf, jtf, ktf -! - jtf = min0(jte,jde-1) - ktf = min0(kte,kde-1) - itf = min0(ite,ide-1) -! - if(.not.restart)then - do j = jts,jtf - do k = kts,ktf - do i = its,itf - rublten(i,k,j) = 0. - rvblten(i,k,j) = 0. - rthblten(i,k,j) = 0. - rqvblten(i,k,j) = 0. - rqcblten(i,k,j) = 0. - enddo - enddo - enddo - endif -! - if (p_qi .ge. p_first_scalar .and. .not.restart) then - do j = jts,jtf - do k = kts,ktf - do i = its,itf - rqiblten(i,k,j) = 0. - enddo - enddo - enddo - endif + do j = jts,jte ! - end subroutine ysuinit -!------------------------------------------------------------------------------- -! ================================================================== - - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea) -! Copied from MYNN PBL - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- + ! Assign input data to local tile-sized arrays. - INTEGER,INTENT(IN) :: KTS,KTE - REAL, INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D - !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !Theta-v PBL lower limit of trust (m). - REAL, PARAMETER :: sbl_damp = 400. !Damping range for averaging with TKE-based PBLH (m). - INTEGER :: I,J,K,kthv,ktke + do n = 1, nmix + do k = kts, kte + do i = its, ite + qmix_hv(i,k,n) = qmix(i,k,j,n) + end do + end do + end do - !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M - k = kts+1 - kthv = 1 - ktke = 1 - maxqke = 0. - minthv = 9.E9 + do k = kts, kte+1 + do i = its, ite + p3di_hv(i,k) = p3di(i,k,j) + end do + end do - DO WHILE (zw1D(k) .LE. 500.) - qtke =MAX(Qke1D(k),0.) ! maximum QKE - IF (maxqke < qtke) then - maxqke = qtke - ktke = k - ENDIF - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - ENDDO - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.025) - TKEeps = MIN(TKEeps,0.25) + do k = kts, kte + do i = its, ite + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + qc3d_hv(i,k) = qc3d(i,k,j) + qi3d_hv(i,k) = qi3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + dz8w_hv(i,k) = dz8w(i,k,j) + rthraten_hv(i,k) = rthraten(i,k,j) + end do + end do - !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 0.75 - ELSE - ! LAND - delt_thv = 1.5 - ENDIF - - zi=0. - k = kthv+1 - DO WHILE (zi .EQ. 0.) - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO + if(present(a_u_bep) .and. present(a_v_bep) .and. present(a_t_bep) .and. & + present(a_q_bep) .and. present(a_e_bep) .and. present(b_u_bep) .and. & + present(b_v_bep) .and. present(b_t_bep) .and. present(b_q_bep) .and. & + present(b_e_bep) .and. present(dlg_bep) .and. present(dl_u_bep) .and. & + present(sf_bep) .and. present(vl_bep) .and. present(frc_urb2d)) then + do k = kts, kte + do i = its,ite + a_u_hv(i,k) = a_u_bep(i,k,j) + a_v_hv(i,k) = a_v_bep(i,k,j) + a_t_hv(i,k) = a_t_bep(i,k,j) + a_q_hv(i,k) = a_q_bep(i,k,j) + a_e_hv(i,k) = a_e_bep(i,k,j) + b_u_hv(i,k) = b_u_bep(i,k,j) + b_v_hv(i,k) = b_v_bep(i,k,j) + b_t_hv(i,k) = b_t_bep(i,k,j) + b_q_hv(i,k) = b_q_bep(i,k,j) + b_e_hv(i,k) = b_e_bep(i,k,j) + dlg_hv(i,k) = dlg_bep(i,k,j) + dl_u_hv(i,k) = dl_u_bep(i,k,j) + vlk_hv(i,k) = vl_bep(i,k,j) + sfk_hv(i,k) = sf_bep(i,k,j) + enddo + enddo + do i = its, ite + frcurb_hv(i) = frc_urb2d(i,j) + enddo + endif - !print*,"IN GET_PBLH:",thsfc,zi - !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - !FIND TKE-BASED PBLH (BEST FOR NOCTURNAL/STABLE CONDITIONS). + do i = its, ite + psfc_hv(i) = psfc(i,j) + znt_hv(i) = znt(i,j) + ust_hv(i) = ust(i,j) + wspd_hv(i) = wspd(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + xland_hv(i) = xland(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + br_hv(i) = br(i,j) + u10_hv(i) = u10(i,j) + v10_hv(i) = v10(i,j) + uoce_hv(i) = uoce(i,j) + voce_hv(i) = voce(i,j) + ctopo_hv(i) = ctopo(i,j) + ctopo2_hv(i) = ctopo2(i,j) + end do +! + call bl_ysu_run(ux=u3d_hv,vx=v3d_hv & + ,tx=t3d_hv & + ,qvx=qv3d_hv,qcx=qc3d_hv,qix=qi3d_hv & + ,f_qc=flag_qc,f_qi=flag_qi & + ,nmix=nmix,qmix=qmix_hv & + ,p2d=p3d_hv,p2di=p3di_hv & + ,pi2d=pi3d_hv & + ,utnp=rublten_hv,vtnp=rvblten_hv & + ,ttnp=rthblten_hv,qvtnp=rqvblten_hv & + ,qctnp=rqcblten_hv,qitnp=rqiblten_hv & + ,qmixtnp=rqmixblten_hv & + ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & + ,xlv=xlv,rv=rv & + ,ep1=ep1,ep2=ep2,karman=karman & + ,dz8w2d=dz8w_hv & + ,psfcpa=psfc_hv,znt=znt_hv,ust=ust_hv & + ,hpbl=hpbl_hv & + ,psim=psim_hv & + ,psih=psih_hv,xland=xland_hv & + ,hfx=hfx_hv,qfx=qfx_hv & + ,wspd=wspd_hv,br=br_hv & + ,dt=dt,kpbl1d=kpbl2d_hv & + ,exch_hx=exch_h_hv & + ,exch_mx=exch_m_hv & + ,wstar=wstar_hv & + ,delta=delta_hv & + ,u10=u10_hv,v10=v10_hv & + ,uox=uoce_hv,vox=voce_hv & + ,rthraten=rthraten_hv & + ,ysu_topdown_pblmix=l_topdown_pblmix & + ,ctopo=ctopo_hv,ctopo2=ctopo2_hv & + ,a_u=a_u_hv,a_v=a_v_hv,a_t=a_t_hv,a_q=a_q_hv,a_e=a_e_hv & + ,b_u=b_u_hv,b_v=b_v_hv,b_t=b_t_hv,b_q=b_q_hv,b_e=b_e_hv & + ,sfk=sfk_hv,vlk=vlk_hv,dlu=dl_u_hv,dlg=dlg_hv,frcurb=frcurb_hv & + ,flag_bep=flag_bep & + ,its=its,ite=ite,kte=kte,kme=kme & + ,errmsg=errmsg,errflg=errflg ) +! + ! Assign local data back to full-sized arrays. + ! Only required for the INTENT(OUT) or INTENT(INOUT) arrays. - PBLH_TKE=0. - k = ktke+1 - DO WHILE (PBLH_TKE .EQ. 0.) - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) - !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. - PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO + do n = 1, nmix + do k = kts, kte + do i = its, ite + rqmixblten(i,k,j,n) = rqmixblten_hv(i,k,n) + end do + end do + end do - !BLEND THE TWO PBLH TYPES HERE: + do k = kts, kte + do i = its, ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + rthblten(i,k,j) = rthblten_hv(i,k)/pi3d_hv(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + rthblten(i,k,j) = rthblten_hv(i,k) +#endif + rqvblten(i,k,j) = rqvblten_hv(i,k) + rqcblten(i,k,j) = rqcblten_hv(i,k) + rqiblten(i,k,j) = rqiblten_hv(i,k) + exch_h(i,k,j) = exch_h_hv(i,k) + exch_m(i,k,j) = exch_m_hv(i,k) + end do + end do - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - zi=PBLH_TKE*(1.-wt) + zi*wt + do i = its, ite + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + hpbl(i,j) = hpbl_hv(i) + kpbl2d(i,j) = kpbl2d_hv(i) + wstar(i,j) = wstar_hv(i) + delta(i,j) = delta_hv(i) + end do + enddo - END SUBROUTINE GET_PBLH -! ================================================================== + end subroutine ysu -end module module_bl_ysu -!------------------------------------------------------------------------------- +!================================================================================================================= + end module module_bl_ysu +!================================================================================================================= diff --git a/phys/module_cu_ntiedtke.F b/phys/module_cu_ntiedtke.F index b638e6e56c..3b56132b66 100644 --- a/phys/module_cu_ntiedtke.F +++ b/phys/module_cu_ntiedtke.F @@ -1,165 +1,36 @@ -!----------------------------------------------------------------------- -! -!wrf:model_layer:physics -! -!####################tiedtke scheme######################### -! m.tiedtke e.c.m.w.f. 1989 -! j.morcrette 1992 -!-------------------------------------------- -! modifications -! C. zhang & Yuqing Wang 2011-2017 -! -! modified from IPRC IRAM - yuqing wang, university of hawaii -! & ICTP REGCM4.4 -! -! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) -! update notes: -! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. -! the major differences to the old Tiedtke (cu_physics=6) scheme are, -! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; -! Bechtold et al. 2004, 2008, 2014). -! (b) Non-equilibrium situations are considered in the closure for deep convection -! (Bechtold et al. 2014). -! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). -! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). -! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). -! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; -! Wu and Yanai 1994) -! -! other refenrence: tiedtke (1989, mwr, 117, 1779-1800) -! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 -! -!=========================================================== -! Note for climate simulation of Tropical Cyclones -! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation -! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km -! Set: momtrans = 2. -! pgcoef = 0.7 to 1.0 is good depends on the basin -! nonequil = .false. -!=========================================================== -! Note for the diurnal simulation of precipitaton -! When nonequil = .true., the CAPE is relaxed toward to a value from PBL -! It can improve the diurnal precipitation over land. -!=========================================================== -!########################################################### - -module module_cu_ntiedtke - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -#if defined(mpas) - use mpas_atmphys_constants, only: rd=>R_d, rv=>R_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g=>gravity -#else - use module_model_constants, only:rd=>r_d, rv=>r_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g -#endif - - implicit none - real,private :: t13,rcpd,vtmpc1,tmelt, & - c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg - - real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice - real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon,pgcoef - integer,private :: momtrans - - parameter( & - t13=1.0/3.0, & - rcpd=1.0/cpd, & - tmelt=273.16, & - zrg=1.0/g, & - c1es=610.78, & - c2es=c1es*rd/rv, & - c3les=17.2693882, & - c3ies=21.875, & - c4les=35.86, & - c4ies=7.66, & - c5les=c3les*(tmelt-c4les), & - c5ies=c3ies*(tmelt-c4ies), & - r5alvcp=c5les*alv*rcpd, & - r5alscp=c5ies*als*rcpd, & - ralvdcp=alv*rcpd, & - ralsdcp=als*rcpd, & - ralfdcp=alf*rcpd, & - rtwat=tmelt, & - rtber=tmelt-5., & - rtice=tmelt-23., & - vtmpc1=rv/rd-1.0 ) -! -! entrdd: average entrainment & detrainment rate for downdrafts -! ------ -! - parameter(entrdd = 2.0e-4) -! -! cmfcmax: maximum massflux value allowed for updrafts etc -! ------- -! - parameter(cmfcmax = 1.0) -! -! cmfcmin: minimum massflux value (for safety) -! ------- -! - parameter(cmfcmin = 1.e-10) -! -! cmfdeps: fractional massflux for downdrafts at lfs -! ------- -! - parameter(cmfdeps = 0.30) - -! zdnoprc: deep cloud is thicker than this height (Unit:Pa) -! - parameter(zdnoprc = 2.0e4) -! ------- -! -! cprcon: coefficient from cloud water to rain water -! - parameter(cprcon = 1.4e-3) -! ------- -! -! momtrans: momentum transport method -! ( 1 = IFS40r1 method; 2 = new method ) -! - parameter(momtrans = 2 ) -! ------- -! -! coefficient for pressure gradient intensity -! (0.7 - 1.0 is recommended in this vesion of Tiedtke scheme) - parameter(pgcoef=0.7) -! ------- -! - logical :: nonequil -! nonequil: representing equilibrium and nonequilibrium convection -! ( .false. [equilibrium: removing all CAPE]; .true. [nonequilibrium: relaxing CAPE toward CAPE from PBL]. -! Ref. Bechtold et al. 2014 JAS ) -! - parameter(nonequil = .true. ) -! -!-------------------- -! switches for deep, mid, shallow convections, downdraft, and momentum transport -! ------------------ - logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv - parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) -!-------------------- -!#################### end of variables definition########################## -!----------------------------------------------------------------------- -! -contains -!----------------------------------------------------------------------- - subroutine cu_ntiedtke( & - dt,itimestep,stepcu & - ,raincv,pratec,qfx,hfx & - ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & - ,qvften,thften & - ,dz8w,pcps,p8w,xland,cu_act_flag,dx & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,rthcuten,rqvcuten,rqccuten,rqicuten & - ,rucuten, rvcuten & - ,f_qv ,f_qc ,f_qr ,f_qi ,f_qs & - ) -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- +!================================================================================================================= + module module_cu_ntiedtke + use ccpp_kind_types,only: kind_phys + + use cu_ntiedtke,only: cu_ntiedtke_run, & + cu_ntiedtke_init + use cu_ntiedtke_common + + implicit none + private + public:: cu_ntiedtke_driver, & + ntiedtkeinit + + + contains + + +!================================================================================================================= + subroutine cu_ntiedtke_driver( & + dt,itimestep,stepcu & + ,raincv,pratec,qfx,hfx & + ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & + ,qvften,thften & + ,dz8w,pcps,p8w,xland,cu_act_flag,dx & + ,f_qv,f_qc,f_qr,f_qi,f_qs & + ,grav,xlf,xls,xlv,rd,rv,cp & + ,rthcuten,rqvcuten,rqccuten,rqicuten & + ,rucuten,rvcuten & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte & + ,errmsg,errflg) +!================================================================================================================= !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) !-- th3d 3d potential temperature (k) @@ -210,3682 +81,453 @@ subroutine cu_ntiedtke( & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile -!------------------------------------------------------------------- - integer, intent(in) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - itimestep, & - stepcu - - real, intent(in) :: & - dt - real, dimension(ims:ime, jms:jme), intent(in) :: & - dx - - real, dimension(ims:ime, jms:jme), intent(in) :: & - xland - - real, dimension(ims:ime, jms:jme), intent(inout) :: & - raincv, pratec - - logical, dimension(ims:ime,jms:jme), intent(inout) :: & - cu_act_flag - - real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: & - dz8w, & - pcps, & - p8w, & - pi3d, & - qc3d, & - qvften, & - thften, & - qi3d, & - qv3d, & - rho3d, & - t3d, & - u3d, & - v3d, & - w - real, dimension(ims:ime, jms:jme) :: & - qfx, & - hfx - -!--------------------------- optional vars ---------------------------- - - real, dimension(ims:ime, kms:kme, jms:jme), & - optional, intent(inout) :: & - rqccuten, & - rqicuten, & - rqvcuten, & - rthcuten, & - rucuten, & - rvcuten - -! -! flags relating to the optional tendency arrays declared above -! models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - logical, optional :: & - f_qv & - ,f_qc & - ,f_qr & - ,f_qi & - ,f_qs - -!--------------------------- local vars ------------------------------ - real :: & - delt, & - rdelt - - real , dimension(its:ite) :: & - rcs, & - rn, & - evap, & - heatflux, & - dx2d - - integer , dimension(its:ite) :: slimsk - - - real , dimension(its:ite, kts:kte+1) :: & - prsi, & - ghti, & - zi - - real , dimension(its:ite, kts:kte) :: & - dot, & - prsl, & - q1, & - q2, & - q3, & - q1b, & - t1b, & - q11, & - q12, & - t1, & - u1, & - v1, & - zl, & - omg, & - ghtl - - integer, dimension(its:ite) :: & - kbot, & - ktop - - integer :: & - i, & - im, & - j, & - k, & - km, & - kp, & - kx, & - kx1 - -!-------other local variables---- - integer :: zz, pp -!----------------------------------------------------------------------- -! -! -!*** check to see if this is a convection timestep -! - -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - cu_act_flag(i,j)=.true. - enddo - enddo - - im=ite-its+1 - kx=kte-kts+1 - kx1=kx+1 - delt=dt*stepcu - rdelt=1./delt - -!------------- j loop (outer) -------------------------------------------------- - - do j=jts,jte - -! --------------- compute zi and zl ----------------------------------------- - do i=its,ite - zi(i,kts)=0.0 - enddo -! - do k=kts,kte - do i=its,ite - zi(i,k+1)=zi(i,k)+dz8w(i,k,j) - enddo - enddo -! - do k=kts,kte - do i=its,ite - zl(i,k)=0.5*(zi(i,k)+zi(i,k+1)) - enddo - enddo - -! --------------- end compute zi and zl ------------------------------------- - do i=its,ite - slimsk(i)=int(abs(xland(i,j)-2.)) - enddo - - do i=its,ite - dx2d(i) = dx(i,j) - enddo - - do k=kts,kte - kp=k+1 - do i=its,ite - dot(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) - enddo - enddo - - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - u1(i,zz)=u3d(i,k,j) - v1(i,zz)=v3d(i,k,j) - t1(i,zz)=t3d(i,k,j) - q1(i,zz)=qv3d(i,k,j) - if(itimestep == 1) then - q1b(i,zz)=0. - t1b(i,zz)=0. - else - q1b(i,zz)=qvften(i,k,j) - t1b(i,zz)=thften(i,k,j) - endif - q2(i,zz)=qc3d(i,k,j) - q3(i,zz)=qi3d(i,k,j) - omg(i,zz)=dot(i,k) - ghtl(i,zz)=zl(i,k) - prsl(i,zz) = pcps(i,k,j) - enddo - pp = pp + 1 - enddo - - pp = 0 - do k=kts,kte+1 - zz = kte+1-pp - do i=its,ite - ghti(i,zz) = zi(i,k) - prsi(i,zz) = p8w(i,k,j) - enddo - pp = pp + 1 - enddo -! - do i=its,ite - evap(i) = qfx(i,j) - heatflux(i)= hfx(i,j) - enddo -! -!######################################################################## - call tiecnvn(u1,v1,t1,q1,q2,q3,q1b,t1b,ghtl,ghti,omg,prsl,prsi,evap,heatflux, & - rn,slimsk,im,kx,kx1,delt,dx2d) - - do i=its,ite - raincv(i,j)=rn(i)/stepcu - pratec(i,j)=rn(i)/(stepcu * dt) - enddo - - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rthcuten(i,k,j)=(t1(i,zz)-t3d(i,k,j))/pi3d(i,k,j)*rdelt - rqvcuten(i,k,j)=(q1(i,zz)-qv3d(i,k,j))*rdelt - rucuten(i,k,j) =(u1(i,zz)-u3d(i,k,j))*rdelt - rvcuten(i,k,j) =(v1(i,zz)-v3d(i,k,j))*rdelt - enddo - pp = pp + 1 - enddo - - if(present(rqccuten))then - if ( f_qc ) then - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt - enddo - pp = pp + 1 +!----------------------------------------------------------------------------------------------------------------- + +!--- input arguments: + logical,intent(in),optional:: f_qv,f_qc,f_qr,f_qi,f_qs + + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: itimestep,stepcu + + real(kind=kind_phys),intent(in):: cp,grav,rd,rv,xlf,xls,xlv + + real(kind=kind_phys),intent(in):: dt + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: dx,hfx,qfx,xland + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + pcps, & + p8w, & + pi3d, & + qc3d, & + qvften, & + thften, & + qi3d, & + qv3d, & + rho3d, & + t3d, & + u3d, & + v3d, & + w + +!--- inout arguments: + logical,intent(inout),dimension(ims:ime,jms:jme):: cu_act_flag + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: raincv, pratec + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + rqccuten, & + rqicuten, & + rqvcuten, & + rthcuten, & + rucuten, & + rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,im,j,k,kx,kx1 + integer,dimension(its:ite):: slimsk + + real(kind=kind_phys):: delt + real(kind=kind_phys),dimension(its:ite):: rn + real(kind=kind_phys),dimension(its:ite,kts:kte):: prsl,omg,ghtl + real(kind=kind_phys),dimension(its:ite,kts:kte):: uf,vf,tf,qvf,qcf,qif + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi,ghti,zi + + real(kind=kind_phys),dimension(its:ite):: dx_hv,hfx_hv,qfx_hv,xland_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: dz_hv,pi_hv,prsl_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,rho_hv,t_hv,u_hv,v_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvften_hv,thften_hv + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi_hv,w_hv + + real(kind=kind_phys),dimension(its:ite):: raincv_hv,pratec_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: rthcuten_hv,rqvcuten_hv,rqccuten_hv,rqicuten_hv, & + rucuten_hv,rvcuten_hv + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = ' ' + errflg = 0 + + call cu_ntiedtke_init( & + con_cp = cp , con_rd = rd , con_rv = rv , con_xlv = xlv , & + con_xls = xls , con_xlf = xlf , con_grav = grav , errmsg = errmsg , & + errflg = errflg & + ) + + do j = jts,jte + do i = its,ite + cu_act_flag(i,j)=.true. + enddo + enddo + + do j = jts,jte + + do i = its,ite + dx_hv(i) = dx(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + xland_hv(i) = xland(i,j) + enddo + + do k = kts,kte + do i = its,ite + dz_hv(i,k) = dz8w(i,k,j) + pi_hv(i,k) = pi3d(i,k,j) + prsl_hv(i,k) = pcps(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + qc_hv(i,k) = qc3d(i,k,j) + qi_hv(i,k) = qi3d(i,k,j) + rho_hv(i,k) = rho3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + + qvften_hv(i,k) = qvften(i,k,j) + thften_hv(i,k) = thften(i,k,j) + enddo + enddo + do k = kts,kte+1 + do i = its,ite + prsi_hv(i,k) = p8w(i,k,j) + w_hv(i,k) = w(i,k,j) + enddo + enddo + + call cu_ntiedtke_pre_run( & + its = its , ite = ite , kts = kts , kte = kte , & + im = im , kx = kx , kx1 = kx1 , itimestep = itimestep , & + stepcu = stepcu , dt = dt , grav = grav , xland = xland_hv , & + dz = dz_hv , pres = prsl_hv , presi = prsi_hv , t = t_hv , & + rho = rho_hv , qv = qv_hv , qc = qc_hv , qi = qi_hv , & + u = u_hv , v = v_hv , w = w_hv , qvften = qvften_hv , & + thften = thften_hv , qvftenz = qvftenz , thftenz = thftenz , slimsk = slimsk , & + delt = delt , prsl = prsl , ghtl = ghtl , tf = tf , & + qvf = qvf , qcf = qcf , qif = qif , uf = uf , & + vf = vf , prsi = prsi , ghti = ghti , omg = omg , & + errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_run( & + pu = uf , pv = vf , pt = tf , pqv = qvf , & + pqc = qcf , pqi = qif , pqvf = qvftenz , ptf = thftenz , & + poz = ghtl , pzz = ghti , pomg = omg , pap = prsl , & + paph = prsi , evap = qfx_hv , hfx = hfx_hv , zprecc = rn , & + lndj = slimsk , lq = im , km = kx , km1 = kx1 , & + dt = delt , dx = dx_hv , errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_post_run( & + its = its , ite = ite , kts = kts , kte = kte , & + stepcu = stepcu , dt = dt , exner = pi_hv , qv = qv_hv , & + qc = qc_hv , qi = qi_hv , t = t_hv , u = u_hv , & + v = v_hv , qvf = qvf , qcf = qcf , qif = qif , & + tf = tf , uf = uf , vf = vf , rn = rn , & + raincv = raincv_hv , pratec = pratec_hv , rthcuten = rthcuten_hv , rqvcuten = rqvcuten_hv , & + rqccuten = rqccuten_hv , rqicuten = rqicuten_hv , rucuten = rucuten_hv , rvcuten = rvcuten_hv , & + errmsg = errmsg , errflg = errflg & + ) + + do i = its,ite + raincv(i,j) = raincv_hv(i) + pratec(i,j) = pratec_hv(i) + enddo + + do k = kts,kte + do i = its,ite + rucuten(i,k,j) = rucuten_hv(i,k) + rvcuten(i,k,j) = rvcuten_hv(i,k) + rthcuten(i,k,j) = rthcuten_hv(i,k) + rqvcuten(i,k,j) = rqvcuten_hv(i,k) + enddo + enddo + + if(present(rqccuten))then + if(f_qc) then + do k = kts,kte + do i = its,ite + rqccuten(i,k,j) = rqccuten_hv(i,k) + enddo enddo - endif - endif - - if(present(rqicuten))then - if ( f_qi ) then - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt - enddo - pp = pp + 1 + endif + endif + + if(present(rqicuten))then + if(f_qi) then + do k = kts,kte + do i = its,ite + rqicuten(i,k,j) = rqicuten_hv(i,k) + enddo enddo - endif - endif - - - enddo - - end subroutine cu_ntiedtke - -!==================================================================== - subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & - rucuten,rvcuten,rthften,rqvften, & - restart,p_qc,p_qi,p_first_scalar, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!-------------------------------------------------------------------- - implicit none -!-------------------------------------------------------------------- - logical , intent(in) :: allowed_to_read,restart - integer , intent(in) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - integer , intent(in) :: p_first_scalar, p_qi, p_qc - - real, dimension( ims:ime , kms:kme , jms:jme ) , intent(out) :: & - rthcuten, & - rqvcuten, & - rqccuten, & - rqicuten, & - rucuten,rvcuten,& - rthften,rqvften - - integer :: i, j, k, itf, jtf, ktf - - jtf=min0(jte,jde-1) - ktf=min0(kte,kde-1) - itf=min0(ite,ide-1) - - if(.not.restart)then - do j=jts,jtf - do k=kts,ktf - do i=its,itf - rthcuten(i,k,j)=0. - rqvcuten(i,k,j)=0. - rucuten(i,k,j)=0. - rvcuten(i,k,j)=0. - enddo - enddo - enddo - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - rthften(i,k,j)=0. - rqvften(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - if (p_qc .ge. p_first_scalar) then - do j=jts,jtf - do k=kts,ktf - do i=its,itf - rqccuten(i,k,j)=0. - enddo - enddo - enddo - endif - - if (p_qi .ge. p_first_scalar) then - do j=jts,jtf - do k=kts,ktf - do i=its,itf - rqicuten(i,k,j)=0. - enddo - enddo - enddo - endif - endif - - end subroutine ntiedtkeinit - -!----------------------------------------------------------------- -! level 1 subroutine 'tiecnvn' -!----------------------------------------------------------------- - subroutine tiecnvn(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & - & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx) -!----------------------------------------------------------------- -! this is the interface between the model and the mass -! flux convection module -!----------------------------------------------------------------- - implicit none -! - real pu(lq,km), pv(lq,km), pt(lq,km), pqv(lq,km) - real poz(lq,km), pomg(lq,km), evap(lq), zprecc(lq) - real pzz(lq,km1) - - real pum1(lq,km), pvm1(lq,km), ztt(lq,km), & - & ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & - & pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km1) - real pqhfl(lq), zqq(lq,km), & - & prsfc(lq), pssfc(lq), pcte(lq,km), & - & phhfl(lq), hfx(lq), pgeoh(lq,km1) - real ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km), & - & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), & - & zqsat(lq,km), pqc(lq,km), pqi(lq,km), zrain(lq) - real pqvf(lq,km), ptf(lq,km) - real dx(lq) - - integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) - logical locum(lq) -! - real ztmst,fliq,fice,ztc,zalf,tt - integer i,j,k,lq,km,km1 - real dt,ztpp1 - real zew,zqs,zcor - real scale_fac(lq), scale_fac2(lq), dxref -! -! set scale-dependency factor when dx is < 15 km -! - dxref = 15000. - do j=1,lq - if (dx(j).lt.dxref) then - scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 - scale_fac2(j) = scale_fac(j)**0.5 - else - scale_fac(j) = 1.+1.33e-5*dx(j) - scale_fac2(j) = 1. - end if - end do -! - ztmst=dt -! -! masv flux diagnostics. -! - do j=1,lq - zrain(j)=0.0 - locum(j)=.false. - prsfc(j)=0.0 - pssfc(j)=0.0 - pqhfl(j)=evap(j) - phhfl(j)=hfx(j) - pgeoh(j,km1)=g*pzz(j,km1) - end do -! -! convert model variables for mflux scheme -! - do k=1,km - do j=1,lq - pcte(j,k)=0.0 - pvom(j,k)=0.0 - pvol(j,k)=0.0 - ztp1(j,k)=pt(j,k) - zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) - pum1(j,k)=pu(j,k) - pvm1(j,k)=pv(j,k) - pverv(j,k)=pomg(j,k) - pgeo(j,k)=g*poz(j,k) - pgeoh(j,k)=g*pzz(j,k) - tt=ztp1(j,k) - zew = foeewm(tt) - zqs = zew/pap(j,k) - zqs = min(0.5,zqs) - zcor = 1./(1.-vtmpc1*zqs) - zqsat(j,k)=zqs*zcor - pqte(j,k)=pqvf(j,k) - zqq(j,k) =pqte(j,k) - ptte(j,k)=ptf(j,k) - ztt(j,k) =ptte(j,k) - end do - end do -! -!----------------------------------------------------------------------- -!* 2. call 'cumastrn'(master-routine for cumulus parameterization) -! - call cumastrn & - & (lq, km, km1, km-1, ztp1, & - & zqp1, pum1, pvm1, pverv, zqsat,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, locum, & - & ktype, icbot, ictop, ztu, zqu, & - & zlu, zlude, zmfu, zmfd, zrain,& - & pcte, phhfl, lndj, pgeoh, dx, & - & scale_fac, scale_fac2) -! -! to include the cloud water and cloud ice detrained from convection -! - do k=1,km - do j=1,lq - if(pcte(j,k).gt.0.) then - fliq=foealfa(ztp1(j,k)) - fice=1.0-fliq - pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst - pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst - endif - end do - end do -! - do k=1,km - do j=1,lq - pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(j,k))*ztmst - zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst - pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) - end do - end do - - do j=1,lq - zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) - end do - - if (lmfdudv) then - do k=1,km - do j=1,lq - pu(j,k)=pu(j,k)+pvom(j,k)*ztmst - pv(j,k)=pv(j,k)+pvol(j,k)*ztmst - end do - end do - endif -! - return - end subroutine tiecnvn - -!############################################################# -! -! level 2 subroutines -! -!############################################################# -!*********************************************************** -! subroutine cumastrn -!*********************************************************** - subroutine cumastrn & - & (klon, klev, klevp1, klevm1, pten, & - & pqen, puen, pven, pverv, pqsen,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, ldcum, & - & ktype, kcbot, kctop, ptu, pqu,& - & plu, plude, pmfu, pmfd, prain,& - & pcte, phhfl, lndj, zgeoh, dx, & - & scale_fac, scale_fac2) - implicit none -! -!***cumastrn* master routine for cumulus massflux-scheme -! m.tiedtke e.c.m.w.f. 1986/1987/1989 -! modifications -! y.wang i.p.r.c 2001 -! c.zhang 2012 -!***purpose -! ------- -! this routine computes the physical tendencies of the -! prognostic variables t,q,u and v due to convective processes. -! processes considered are: convective fluxes, formation of -! precipitation, evaporation of falling rain below cloud base, -! saturated cumulus downdrafts. -!***method -! ------ -! parameterization is done using a massflux-scheme. -! (1) define constants and parameters -! (2) specify values (t,q,qs...) at half levels and -! initialize updraft- and downdraft-values in 'cuinin' -! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, -! and specify cloud base massflux -! (4) do cloud ascent in 'cuascn' in absence of downdrafts -! (5) do downdraft calculations: -! (a) determine values at lfs in 'cudlfsn' -! (b) determine moist descent in 'cuddrafn' -! (c) recalculate cloud base massflux considering the -! effect of cu-downdrafts -! (6) do final adjusments to convective fluxes in 'cuflxn', -! do evaporation in subcloud layer -! (7) calculate increments of t and q in 'cudtdqn' -! (8) calculate increments of u and v in 'cududvn' -!***externals. -! ---------- -! cuinin: initializes values at vertical grid used in cu-parametr. -! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus -! cuascn: cloud ascent for entraining plume -! cudlfsn: determines values at lfs for downdrafts -! cuddrafn:does moist descent for cumulus downdrafts -! cuflxn: final adjustments to convective fluxes (also in pbl) -! cudqdtn: updates tendencies for t and q -! cududvn: updates tendencies for u and v -!***switches. -! -------- -! lmfmid=.t. midlevel convection is switched on -! lmfdd=.t. cumulus downdrafts switched on -! lmfdudv=.t. cumulus friction switched on -!*** -! model parameters (defined in subroutine cuparam) -! ------------------------------------------------ -! entrdd entrainment rate for cumulus downdrafts -! cmfcmax maximum massflux value allowed for -! cmfcmin minimum massflux value (for safety) -! cmfdeps fractional massflux for downdrafts at lfs -! cprcon coefficient for conversion from cloud water to rain -!***reference. -! ---------- -! paper on massflux scheme (tiedtke,1989) -!----------------------------------------------------------------- - integer klev,klon,klevp1,klevm1 - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & ptte(klon,klev), pqte(klon,klev),& - & pvom(klon,klev), pvol(klon,klev),& - & pqsen(klon,klev), pgeo(klon,klev),& - & pap(klon,klev), paph(klon,klevp1),& - & pverv(klon,klev), pqhfl(klon),& - & phhfl(klon) - real ptu(klon,klev), pqu(klon,klev),& - & plu(klon,klev), plude(klon,klev),& - & pmfu(klon,klev), pmfd(klon,klev),& - & prain(klon),& - & prsfc(klon), pssfc(klon) - real ztenh(klon,klev), zqenh(klon,klev),& - & zgeoh(klon,klevp1), zqsenh(klon,klev),& - & ztd(klon,klev), zqd(klon,klev),& - & zmfus(klon,klev), zmfds(klon,klev),& - & zmfuq(klon,klev), zmfdq(klon,klev),& - & zdmfup(klon,klev), zdmfdp(klon,klev),& - & zmful(klon,klev), zrfl(klon),& - & zuu(klon,klev), zvu(klon,klev),& - & zud(klon,klev), zvd(klon,klev),& - & zlglac(klon,klev) - real pmflxr(klon,klevp1), pmflxs(klon,klevp1) - real zhcbase(klon),& - & zmfub(klon), zmfub1(klon),& - & zdhpbl(klon) - real zsfl(klon), zdpmel(klon,klev),& - & pcte(klon,klev), zcape(klon),& - & zcape1(klon), zcape2(klon),& - & ztauc(klon), ztaubl(klon),& - & zheat(klon) - real wup(klon), zdqcv(klon) - real wbase(klon), zmfuub(klon) - real upbl(klon) - real dx(klon) - real pmfude_rate(klon,klev), pmfdde_rate(klon,klev) - real zmfuus(klon,klev), zmfdus(klon,klev) - real zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) - real zmfuvb(klon),zsum12(klon),zsum22(klon) - integer ilab(klon,klev), idtop(klon),& - & ictop0(klon), ilwmin(klon) - integer kdpl(klon) - integer kcbot(klon), kctop(klon),& - & ktype(klon), lndj(klon) - logical ldcum(klon) - logical loddraf(klon), llo1, llo2(klon) - real scale_fac(klon), scale_fac2(klon) - -! local varaiables - real zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax - real zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat - real zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed - integer jl,jk,ik - integer ikb,ikt,icum,itopm2 - real ztmst,ztau,zerate,zderate,zmfa - real zmfs(klon),pmean(klev),zlon - real zduten,zdvten,ztdis,pgf_u,pgf_v -!------------------------------------------- -! 1. specify constants and parameters -!------------------------------------------- - zcons=1./(g*ztmst) - zcons2=3./(g*ztmst) - -!-------------------------------------------------------------- -!* 2. initialize values at vertical grid points in 'cuini' -!-------------------------------------------------------------- - call cuinin & - & (klon, klev, klevp1, klevm1, pten, & - & pqen, pqsen, puen, pven, pverv,& - & pgeo, paph, zgeoh, ztenh, zqenh,& - & zqsenh, ilwmin, ptu, pqu, ztd, & - & zqd, zuu, zvu, zud, zvd, & - & pmfu, pmfd, zmfus, zmfds, zmfuq,& - & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & - & plude, ilab) - -!---------------------------------- -!* 3.0 cloud base calculations -!---------------------------------- -!* (a) determine cloud base values in 'cutypen', -! and the cumulus type 1 or 2 -! ------------------------------------------- - call cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ztenh, zqenh, zqsenh, zgeoh, paph,& - & phhfl, pqhfl, pgeo, pqsen, pap,& - & pten, lndj, ptu, pqu, ilab,& - & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) - -!* (b) assign the first guess mass flux at cloud base -! ------------------------------------------ - do jl=1,klon - zdhpbl(jl)=0.0 - upbl(jl) = 0.0 - idtop(jl)=0 - end do - - do jk=2,klev - do jl=1,klon - if(jk.ge.kcbot(jl) .and. ldcum(jl)) then - zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& - & *(paph(jl,jk+1)-paph(jl,jk)) - if(lndj(jl) .eq. 0) then - wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) - upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - if(ktype(jl) == 1) then - zmfub(jl)= 0.1*zmfmax - else if ( ktype(jl) == 2 ) then - zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) - zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) - zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe - zdh = g*max(zdh,1.e5*zdqmin) - if ( zdhpbl(jl) > 0. ) then - zmfub(jl) = zdhpbl(jl)/zdh - zmfub(jl) = min(zmfub(jl),zmfmax) - else - zmfub(jl) = 0.1*zmfmax - ldcum(jl) = .false. - end if - end if - else - zmfub(jl) = 0. - end if - end do -!------------------------------------------------------ -!* 4.0 determine cloud ascent for entraining plume -!------------------------------------------------------ -!* (a) do ascent in 'cuasc'in absence of downdrafts -!---------------------------------------------------------- - call cuascn & - & (klon, klev, klevp1, klevm1, ztenh,& - & zqenh, puen, pven, pten, pqen,& - & pqsen, pgeo, zgeoh, pap, paph,& - & pqte, pverv, ilwmin, ldcum, zhcbase,& - & ktype, ilab, ptu, pqu, plu,& - & zuu, zvu, pmfu, zmfub,& - & zmfus, zmfuq, zmful, plude, zdmfup,& - & kcbot, kctop, ictop0, icum, ztmst,& - & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate) - -!* (b) check cloud depth and change entrainment rate accordingly -! calculate precipitation rate (for downdraft calculation) -!------------------------------------------------------------------ - do jl=1,klon - if ( ldcum(jl) ) then - ikb = kcbot(jl) - itopm2 = kctop(jl) - zpbmpt = paph(jl,ikb) - paph(jl,itopm2) - if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 - if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 - ictop0(jl) = kctop(jl) - end if - zrfl(jl)=zdmfup(jl,1) - end do - - do jk=2,klev - do jl=1,klon - zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) - end do - end do - - do jk = 1,klev - do jl = 1,klon - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - zdpmel(jl,jk) = 0. - end do - end do - -!----------------------------------------- -!* 6.0 cumulus downdraft calculations -!----------------------------------------- - if(lmfdd) then -!* (a) determine lfs in 'cudlfsn' -!-------------------------------------- - call cudlfsn & - & (klon, klev,& - & kcbot, kctop, lndj, ldcum, & - & ztenh, zqenh, puen, pven, & - & pten, pqsen, pgeo, & - & zgeoh, paph, ptu, pqu, plu, & - & zuu, zvu, zmfub, zrfl, & - & ztd, zqd, zud, zvd, & - & pmfd, zmfds, zmfdq, zdmfdp, & - & idtop, loddraf) -!* (b) determine downdraft t,q and fluxes in 'cuddrafn' -!------------------------------------------------------------ - call cuddrafn & - & ( klon, klev, loddraf, & - & ztenh, zqenh, puen, pven, & - & pgeo, zgeoh, paph, zrfl, & - & ztd, zqd, zud, zvd, pmfu, & - & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) -!----------------------------------------------------------- - end if -! -!----------------------------------------------------------------------- -!* 6.0 closure and clean work -! ------ -!-- 6.1 recalculate cloud base massflux from a cape closure -! for deep convection (ktype=1) -! - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 1) then - ikb = kcbot(jl) - ikt = kctop(jl) - zheat(jl)=0.0 - zcape(jl)=0.0 - zcape1(jl)=0.0 - zcape2(jl)=0.0 - zmfub1(jl)=zmfub(jl) - - ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & - ((2.+ min(15.0,wup(jl)))*g) - if(lndj(jl) .eq. 0) then - upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) - ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) - ztaubl(jl) = min(300., ztaubl(jl)) - else - ztaubl(jl) = ztauc(jl) - end if - end if - end do -! - do jk = 1 , klev - do jl = 1 , klon - llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 - if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then - ikb = kcbot(jl) - zdz = pgeo(jl,jk-1)-pgeo(jl,jk) - zdp = pap(jl,jk)-pap(jl,jk-1) - zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & - ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & - (g*(pmfu(jl,jk)+pmfd(jl,jk))) - zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & - vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp - end if - - if ( llo1 .and. jk >= kcbot(jl) ) then - if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then - zdp = paph(jl,jk+1)-paph(jl,jk) - zcape2(jl) = zcape2(jl) + ztaubl(jl)* & - ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl).and.ktype(jl).eq.1) then - ikb = kcbot(jl) - ikt = kctop(jl) - ztauc(jl) = max(ztmst,ztauc(jl)) - ztauc(jl) = max(360.,ztauc(jl)) - ztauc(jl) = min(10800.,ztauc(jl)) - ztau = ztauc(jl) * scale_fac(jl) - if(nonequil) then - zcape2(jl)= max(0.,zcape2(jl)) - zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) - else - zcape(jl) = max(0.,min(zcape1(jl),5000.)) - end if - zheat(jl) = max(1.e-4,zheat(jl)) - zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) - zmfub1(jl) = max(zmfub1(jl),0.001) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - zmfub1(jl)=min(zmfub1(jl),zmfmax) - end if - end do -! -!* 6.2 recalculate convective fluxes due to effect of -! downdrafts on boundary layer moist static energy budget (ktype=2) -!-------------------------------------------------------- - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 2) then - ikb=kcbot(jl) - if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then - zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) - else - zeps=0. - endif - zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & - & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) - zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 -! using moist static engergy closure instead of moisture closure - zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & - & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe - zdh=g*max(zdh,1.e5*zdqmin) - if(zdhpbl(jl).gt.0.)then - zmfub1(jl)=zdhpbl(jl)/zdh - else - zmfub1(jl) = zmfub(jl) - end if - zmfub1(jl) = zmfub1(jl)/scale_fac2(jl) - zmfub1(jl) = min(zmfub1(jl),zmfmax) - end if - -!* 6.3 mid-level convection - nothing special -!--------------------------------------------------------- - if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then - zmfub1(jl) = zmfub(jl) - end if - - end do - -!* 6.4 scaling the downdraft mass flux -!--------------------------------------------------------- - do jk=1,klev - do jl=1,klon - if( ldcum(jl) ) then - zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) - pmfd(jl,jk)=pmfd(jl,jk)*zfac - zmfds(jl,jk)=zmfds(jl,jk)*zfac - zmfdq(jl,jk)=zmfdq(jl,jk)*zfac - zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac - end if - end do - end do - -!* 6.5 scaling the updraft mass flux -! -------------------------------------------------------- - do jl = 1,klon - if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - ikb = kcbot(jl) - if ( jk>ikb ) then - zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - pmfu(jl,jk) = pmfu(jl,ikb)*zdz - end if - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then - pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) - zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) - zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) - zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) - plude(jl,jk) = plude(jl,jk)*zmfs(jl) - pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) - end if - end do - end do - -!* 6.6 if ktype = 2, kcbot=kctop is not allowed -! --------------------------------------------------- - do jl = 1,klon - if ( ktype(jl) == 2 .and. & - kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then - ldcum(jl) = .false. - ktype(jl) = 0 - end if - end do - - if ( .not. lmfscv .or. .not. lmfpen ) then - do jl = 1,klon - llo2(jl) = .false. - if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & - (.not. lmfpen .and. ktype(jl) == 1) ) then - llo2(jl) = .true. - ldcum(jl) = .false. - end if - end do - end if - -!* 6.7 set downdraft mass fluxes to zero above cloud top -!---------------------------------------------------- - do jl = 1,klon - if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then - idtop(jl) = kctop(jl) + 1 - end if - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) ) then - if ( jk < idtop(jl) ) then - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - else if ( jk == idtop(jl) ) then - pmfdde_rate(jl,jk) = 0. - end if - end if - end do - end do -!---------------------------------------------------------- -!* 7.0 determine final convective fluxes in 'cuflx' -!---------------------------------------------------------- - call cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ztenh, zqenh & - & , paph, pap, zgeoh, lndj, ldcum & - & , kcbot, kctop, idtop, itopm2 & - & , ktype, loddraf & - & , pmfu, pmfd, zmfus, zmfds & - & , zmfuq, zmfdq, zmful, plude & - & , zdmfup, zdmfdp, zdpmel, zlglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! some adjustments needed - do jl=1,klon - zmfs(jl) = 1. - zmfuub(jl)=0. - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zmfmax = pmfu(jl,jk)*0.98 - if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then - zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) - end if - end if - end do - end do - - do jk = 2 , klev - do jl = 1 , klon - if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then - pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) - zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) - zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) - zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) - pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) - zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) - end if - end do - end do - - do jk = 2 , klev - 1 - do jl = 1, klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) - if ( zerate < 0. ) then - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate - end if - end if - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) - if ( zerate < 0. ) then - pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate - end if - zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & - pmflxr(jl,jk) - pmflxs(jl,jk) - zdmfdp(jl,jk) = 0. - end if - end do - end do - -! avoid negative humidities at ddraught top - do jl = 1,klon - if ( loddraf(jl) ) then - jk = idtop(jl) - ik = min(jk+1,klev) - if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then - zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) - end if - end if - end do - -! avoid negative humidities near cloud top because gradient of precip flux -! and detrainment / liquid water flux are too large - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then - zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) - zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & - zmfuq(jl,jk) - zmfdq(jl,jk) + & - zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) - zmfa = (zmfa-plude(jl,jk))*zdz - if ( pqen(jl,jk)+zmfa < 0. ) then - plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz - end if - if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. - end if - if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. - if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. - end do - end do - - do jl=1,klon - prsfc(jl) = pmflxr(jl,klev+1) - pssfc(jl) = pmflxs(jl,klev+1) - end do - -!---------------------------------------------------------------- -!* 8.0 update tendencies for t and q in subroutine cudtdq -!---------------------------------------------------------------- - call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & - ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & - zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & - zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) -!---------------------------------------------------------------- -!* 9.0 update tendencies for u and u in subroutine cududv -!---------------------------------------------------------------- - if(lmfdudv) then - do jk = klev-1 , 2 , -1 - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then - ikb = kdpl(jl) - zuu(jl,jk) = puen(jl,ikb-1) - zvu(jl,jk) = pven(jl,ikb-1) - else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then - zuu(jl,jk) = puen(jl,jk-1) - zvu(jl,jk) = pven(jl,jk-1) - end if - if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then - if(momtrans .eq. 1)then - zfac = 0. - if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. - if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. - zerate = pmfu(jl,jk) - pmfu(jl,ik) + & - (1.+zfac)*pmfude_rate(jl,jk) - zderate = (1.+zfac)*pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa - else - pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) - zderate = pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa - end if - end if - end if - end do - end do - - if(lmfdd) then - do jk = 3 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == idtop(jl) ) then - zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) - zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) - else if ( jk > idtop(jl) ) then - zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) - zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) - zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & - zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa - zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & - zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa - end if - end if - end do - end do - end if -! -------------------------------------------------- -! rescale massfluxes for stability in Momentum -!------------------------------------------------------------------------ - zmfs(:) = 1. - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons - if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - zmfuus(jl,jk) = pmfu(jl,jk) - zmfdus(jl,jk) = pmfd(jl,jk) - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) - end if - end do - end do -!* 9.1 update u and v in subroutine cududvn -!------------------------------------------------------------------- - do jk = 1 , klev - do jl = 1, klon - ztenu(jl,jk) = pvom(jl,jk) - ztenv(jl,jk) = pvol(jl,jk) - end do - end do - - call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & - ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & - zud,zvu,zvd,pvom,pvol) - -! calculate KE dissipation - do jl = 1, klon - zsum12(jl) = 0. - zsum22(jl) = 0. - end do - do jk = 1 , klev - do jl = 1, klon - zuv2(jl,jk) = 0. - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zdz = (paph(jl,jk+1)-paph(jl,jk)) - zduten = pvom(jl,jk) - ztenu(jl,jk) - zdvten = pvol(jl,jk) - ztenv(jl,jk) - zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) - zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz - zsum12(jl) = zsum12(jl) - & - (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then - ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) - ptte(jl,jk) = ptte(jl,jk) + ztdis - end if - end do - end do - - end if - -!---------------------------------------------------------------------- -!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF -! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO -! --------------------------------------------------- - if ( .not. lmfscv .or. .not. lmfpen ) then - do jk = 2 , klev - do jl = 1, klon - if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then - ptu(jl,jk) = pten(jl,jk) - pqu(jl,jk) = pqen(jl,jk) - plu(jl,jk) = 0. - pmfude_rate(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - end if - end do - end do - do jl = 1, klon - if ( llo2(jl) ) then - kctop(jl) = klev - 1 - kcbot(jl) = klev - 1 - end if - end do - end if - - return - end subroutine cumastrn - -!********************************************** -! level 3 subroutine cuinin -!********************************************** -! - subroutine cuinin & - & (klon, klev, klevp1, klevm1, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, paph, pgeoh, ptenh, pqenh,& - & pqsenh, klwmin, ptu, pqu, ptd,& - & pqd, puu, pvu, pud, pvd,& - & pmfu, pmfd, pmfus, pmfds, pmfuq,& - & pmfdq, pdmfup, pdmfdp, pdpmel, plu,& - & plude, klab) - implicit none -! m.tiedtke e.c.m.w.f. 12/89 -!***purpose -! ------- -! this routine interpolates large-scale fields of t,q etc. -! to half levels (i.e. grid for massflux scheme), -! and initializes values for updrafts and downdrafts -!***interface -! --------- -! this routine is called from *cumastr*. -!***method. -! -------- -! for extrapolation to half levels see tiedtke(1989) -!***externals -! --------- -! *cuadjtq* to specify qs at half levels -! ---------------------------------------------------------------- - integer klon,klev,klevp1,klevm1 - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & pqsen(klon,klev), pverv(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & paph(klon,klevp1), ptenh(klon,klev),& - & pqenh(klon,klev), pqsenh(klon,klev) - real ptu(klon,klev), pqu(klon,klev),& - & ptd(klon,klev), pqd(klon,klev),& - & puu(klon,klev), pud(klon,klev),& - & pvu(klon,klev), pvd(klon,klev),& - & pmfu(klon,klev), pmfd(klon,klev),& - & pmfus(klon,klev), pmfds(klon,klev),& - & pmfuq(klon,klev), pmfdq(klon,klev),& - & pdmfup(klon,klev), pdmfdp(klon,klev),& - & plu(klon,klev), plude(klon,klev) - real zwmax(klon), zph(klon), & - & pdpmel(klon,klev) - integer klab(klon,klev), klwmin(klon) - logical loflag(klon) -! local variables - integer jl,jk - integer icall,ik - real zzs -!------------------------------------------------------------ -!* 1. specify large scale parameters at half levels -!* adjust temperature fields if staticly unstable -!* find level of maximum vertical velocity -! ----------------------------------------------------------- - do jk=2,klev - do jl=1,klon - ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & - & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd - pqenh(jl,jk) = pqen(jl,jk-1) - pqsenh(jl,jk)= pqsen(jl,jk-1) - zph(jl)=paph(jl,jk) - loflag(jl)=.true. - end do - - if ( jk >= klev-1 .or. jk < 2 ) cycle - ik=jk - icall=0 - call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) - do jl=1,klon - pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & - & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) - pqenh(jl,jk)=max(pqenh(jl,jk),0.) - end do - end do - - do jl=1,klon - ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & - & pgeoh(jl,klev))*rcpd - pqenh(jl,klev)=pqen(jl,klev) - ptenh(jl,1)=pten(jl,1) - pqenh(jl,1)=pqen(jl,1) - klwmin(jl)=klev - zwmax(jl)=0. - end do - - do jk=klevm1,2,-1 - do jl=1,klon - zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & - & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) - ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd - end do - end do - - do jk=klev,3,-1 - do jl=1,klon - if(pverv(jl,jk).lt.zwmax(jl)) then - zwmax(jl)=pverv(jl,jk) - klwmin(jl)=jk - end if - end do - end do -!----------------------------------------------------------- -!* 2.0 initialize values for updrafts and downdrafts -!----------------------------------------------------------- - do jk=1,klev - ik=jk-1 - if(jk.eq.1) ik=1 - do jl=1,klon - ptu(jl,jk)=ptenh(jl,jk) - ptd(jl,jk)=ptenh(jl,jk) - pqu(jl,jk)=pqenh(jl,jk) - pqd(jl,jk)=pqenh(jl,jk) - plu(jl,jk)=0. - puu(jl,jk)=puen(jl,ik) - pud(jl,jk)=puen(jl,ik) - pvu(jl,jk)=pven(jl,ik) - pvd(jl,jk)=pven(jl,ik) - klab(jl,jk)=0 - end do - end do - return - end subroutine cuinin - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ptenh, pqenh, pqsenh, pgeoh, paph,& - & hfx, qfx, pgeo, pqsen, pap,& - & pten, lndj, cutu, cuqu, culab,& - & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) -! zhang & wang iprc 2011-2013 -!***purpose. -! -------- -! to produce first guess updraught for cu-parameterizations -! calculates condensation level, and sets updraught base variables and -! first guess cloud type -!***interface -! --------- -! this routine is called from *cumastr*. -! input are environm. values of t,q,p,phi at half levels. -! it returns cloud types as follows; -! ktype=1 for deep cumulus -! ktype=2 for shallow cumulus -!***method. -! -------- -! based on a simplified updraught equation -! partial(hup)/partial(z)=eta(h - hup) -! eta is the entrainment rate for test parcel -! h stands for dry static energy or the total water specific humidity -! references: christian jakob, 2003: a new subcloud model for -! mass-flux convection schemes -! influence on triggering, updraft properties, and model -! climate, mon.wea.rev. -! 131, 2765-2778 -! and -! ifs documentation - cy36r1,cy38r1 -!***input variables: -! ptenh [ztenh] - environment temperature on half levels. (cuini) -! pqenh [zqenh] - env. specific humidity on half levels. (cuini) -! pgeoh [zgeoh] - geopotential on half levels, (mssflx) -! paph - pressure of half levels. (mssflx) -! rho - density of the lowest model level -! qfx - net upward moisture flux at the surface (kg/m^2/s) -! hfx - net upward heat flux at the surface (w/m^2) -!***variables output by cutype: -! ktype - convection type - 1: penetrative (cumastr) -! 2: stratocumulus (cumastr) -! 3: mid-level (cuasc) -! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) -! ---------------------------------------------------------------- -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - integer klon, klev, klevp1, klevm1 - real ptenh(klon,klev), pqenh(klon,klev),& - & pqsen(klon,klev), pqsenh(klon,klev),& - & pgeoh(klon,klevp1), paph(klon,klevp1),& - & pap(klon,klev), pqen(klon,klev) - real pten(klon,klev) - real ptu(klon,klev),pqu(klon,klev),plu(klon,klev) - real pgeo(klon,klev) - integer klab(klon,klev) - integer kctop(klon),kcbot(klon) - - real qfx(klon),hfx(klon) - real zph(klon) - integer lndj(klon) - logical loflag(klon), deepflag(klon), resetflag(klon) - -! output variables - real cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) - integer culab(klon,klev) - real wbase(klon) - integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) - logical ldcum(klon) - -! local variables - real zqold(klon) - real rho, part1, part2, root, conw, deltt, deltq - real eta(klon),dz(klon),coef(klon) - real dhen(klon,klev), dh(klon,klev) - real plude(klon,klev) - real kup(klon,klev) - real vptu(klon,klev),vten(klon,klev) - real zbuo(klon,klev),abuoy(klon,klev) - - real zz,zdken,zdq - real fscale,crirh1,pp - real atop1,atop2,abot - real tmix,zmix,qmix,pmix - real zlglac,dp - integer nk,is,ikb,ikt - - real zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp - real zpdifftop, zpdiffbot - integer zcbase(klon), itoppacel(klon) - integer jl,jk,ik,icall,levels - logical needreset, lldcum(klon) -!-------------------------------------------------------------- - do jl=1,klon - kcbot(jl)=klev - kctop(jl)=klev - kdpl(jl) =klev - ktype(jl)=0 - wbase(jl)=0. - ldcum(jl)=.false. - end do - -!----------------------------------------------------------- -! let's do test,and check the shallow convection first -! the first level is klev -! define deltat and deltaq -!----------------------------------------------------------- - do jk=1,klev - do jl=1,klon - plu(jl,jk)=culu(jl,jk) ! parcel liquid water - ptu(jl,jk)=cutu(jl,jk) ! parcel temperature - pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity - klab(jl,jk)=culab(jl,jk) - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading - vten(jl,jk)=0.0 ! environment virtual temperature - zbuo(jl,jk)=0.0 ! parcel buoyancy - abuoy(jl,jk)=0.0 - end do - end do - - do jl=1,klon - zqold(jl) = 0. - lldcum(jl) = .false. - loflag(jl) = .true. - end do - -! check the levels from lowest level to second top level - do jk=klevm1,2,-1 - -! define the variables at the first level - if(jk .eq. klevm1) then - do jl=1,klon - rho=pap(jl,klev)/ & - & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) - part1 = 1.5*0.4*pgeo(jl,klev)/ & - & (rho*pten(jl,klev)) - part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) - root = 0.001-part1*part2 - if(part2 .lt. 0.) then - conw = 1.2*(root)**t13 - deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) - deltq = max(1.5*qfx(jl)/(rho*conw),0.) - kup(jl,klev) = 0.5*(conw**2) - pqu(jl,klev)= pqenh(jl,klev) + deltq - dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd - dh(jl,klev) = dhen(jl,klev) + deltt*cpd - ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd - vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) - vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) - zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) - klab(jl,klev) = 1 - else - loflag(jl) = .false. - end if - end do - end if - - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then - eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4 - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = min(plu(jl,jk),5.e-3) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot - -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else - if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end if - end do - - end do ! end all the levels - - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 2 - ldcum(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = klev - else - cutop(jl) = -1 - cubot(jl) = -1 - kdpl(jl) = klev - 1 - ldcum(jl) = .false. - wbase(jl) = 0. - end if - end do - - do jk=klev,1,-1 - do jl=1,klon - ikt = kctop(jl) - if(jk .ge. ikt)then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - end if - end do - end do - -!----------------------------------------------------------- -! next, let's check the deep convection -! the first level is klevm1-1 -! define deltat and deltaq -!---------------------------------------------------------- -! we check the parcel starting level by level -! assume the mix-layer is 60hPa - deltt = 0.2 - deltq = 1.0e-4 - do jl=1,klon - deepflag(jl) = .false. - end do - - do jk=klev,1,-1 - do jl=1,klon - if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk - end do - end do - - do levels=klevm1-1,klev/2+1,-1 ! loop starts - do jk=1,klev - do jl=1,klon - plu(jl,jk)=0.0 ! parcel liquid water - ptu(jl,jk)=0.0 ! parcel temperature - pqu(jl,jk)=0.0 ! parcel specific humidity - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading - vten(jl,jk)=0.0 ! environment virtual temperature - abuoy(jl,jk)=0.0 - zbuo(jl,jk)=0.0 - klab(jl,jk)=0 - end do - end do - - do jl=1,klon - kcbot(jl) = levels - kctop(jl) = levels - zqold(jl) = 0. - lldcum(jl) = .false. - resetflag(jl)= .false. - loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) - end do - -! start the inner loop to search the deep convection points - do jk=levels,2,-1 - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! define the variables at the departure level - if(jk .eq. levels) then - do jl=1,klon - if(loflag(jl)) then - if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then - tmix=0. - qmix=0. - zmix=0. - pmix=0. - do nk=jk+2,jk,-1 - if(pmix < 50.e2) then - dp = paph(jl,nk) - paph(jl,nk-1) - tmix=tmix+dp*ptenh(jl,nk) - qmix=qmix+dp*pqenh(jl,nk) - zmix=zmix+dp*pgeoh(jl,nk) - pmix=pmix+dp - end if - end do - tmix=tmix/pmix - qmix=qmix/pmix - zmix=zmix/pmix - else - tmix=ptenh(jl,jk+1) - qmix=pqenh(jl,jk+1) - zmix=pgeoh(jl,jk+1) - end if - - pqu(jl,jk+1) = qmix + deltq - dhen(jl,jk+1)= zmix + tmix*cpd - dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd - ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd - kup(jl,jk+1) = 0.5 - klab(jl,jk+1)= 1 - vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) - vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) - zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) - end if - end do - end if - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then -! define the fscale - fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) - eta(jl) = 1.75e-3*fscale - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = 0.5*plu(jl,jk) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else - if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end if - end do - - end do ! end all the levels - - needreset = .false. - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 1 - ldcum(jl) = .true. - deepflag(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = levels+1 - needreset = .true. - resetflag(jl)= .true. - end if - end do - - if(needreset) then - do jk=klev,1,-1 - do jl=1,klon - if(resetflag(jl)) then - ikt = kctop(jl) - ikb = kdpl(jl) - if(jk .le. ikb .and. jk .ge. ikt )then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - else - culab(jl,jk) = 1 - cutu(jl,jk) = ptenh(jl,jk) - cuqu(jl,jk) = pqenh(jl,jk) - culu(jl,jk) = 0. - end if - if ( jk .lt. ikt ) culab(jl,jk) = 0 - end if - end do - end do - end if - - end do ! end all cycles - - return - end subroutine cutypen - -!----------------------------------------------------------------- -! level 3 subroutines 'cuascn' -!----------------------------------------------------------------- - subroutine cuascn & - & (klon, klev, klevp1, klevm1, ptenh,& - & pqenh, puen, pven, pten, pqen,& - & pqsen, pgeo, pgeoh, pap, paph,& - & pqte, pverv, klwmin, ldcum, phcbase,& - & ktype, klab, ptu, pqu, plu,& - & puu, pvu, pmfu, pmfub, & - & pmfus, pmfuq, pmful, plude, pdmfup,& - & kcbot, kctop, kctop0, kcum, ztmst,& - & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) - implicit none -! this routine does the calculations for cloud ascents -! for cumulus parameterization -! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 -! y.wang iprc 11/01 modif. -! c.zhang iprc 05/12 modif. -!***purpose. -! -------- -! to produce cloud ascents for cu-parametrization -! (vertical profiles of t,q,l,u and v and corresponding -! fluxes as well as precipitation rates) -!***interface -! --------- -! this routine is called from *cumastr*. -!***method. -! -------- -! lift surface air dry-adiabatically to cloud base -! and then calculate moist ascent for -! entraining/detraining plume. -! entrainment and detrainment rates differ for -! shallow and deep cumulus convection. -! in case there is no penetrative or shallow convection -! check for possibility of mid level convection -! (cloud base values calculated in *cubasmc*) -!***externals -! --------- -! *cuadjtqn* adjust t and q due to condensation in ascent -! *cuentrn* calculate entrainment/detrainment rates -! *cubasmcn* calculate cloud base values for midlevel convection -!***reference -! --------- -! (tiedtke,1989) -!***input variables: -! ptenh [ztenh] - environ temperature on half levels. (cuini) -! pqenh [zqenh] - env. specific humidity on half levels. (cuini) -! puen - environment wind u-component. (mssflx) -! pven - environment wind v-component. (mssflx) -! pten - environment temperature. (mssflx) -! pqen - environment specific humidity. (mssflx) -! pqsen - environment saturation specific humidity. (mssflx) -! pgeo - geopotential. (mssflx) -! pgeoh [zgeoh] - geopotential on half levels, (mssflx) -! pap - pressure in pa. (mssflx) -! paph - pressure of half levels. (mssflx) -! pqte - moisture convergence (delta q/delta t). (mssflx) -! pverv - large scale vertical velocity (omega). (mssflx) -! klwmin [ilwmin] - level of minimum omega. (cuini) -! klab [ilab] - level label - 1: sub-cloud layer. -! 2: condensation level (cloud base) -! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) -!***variables modified by cuasc: -! ldcum - logical denoting profiles. (cubase) -! ktype - convection type - 1: penetrative (cumastr) -! 2: stratocumulus (cumastr) -! 3: mid-level (cuasc) -! ptu - cloud temperature. -! pqu - cloud specific humidity. -! plu - cloud liquid water (moisture condensed out) -! puu [zuu] - cloud momentum u-component. -! pvu [zvu] - cloud momentum v-component. -! pmfu - updraft mass flux. -! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) -! pmfuq [zmfuq] - updraft flux of specific humidity. -! pmful [zmful] - updraft flux of cloud liquid water. -! plude - liquid water returned to environment by detrainment. -! pdmfup [zmfup] - -! kcbot - cloud base level. (cubase) -! kctop - cloud top level -! kctop0 [ictop0] - estimate of cloud top. (cumastr) -! kcum [icum] - flag to control the call - - integer klev,klon,klevp1,klevm1 - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev),& - & pten(klon,klev), pqen(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & pap(klon,klev), paph(klon,klevp1),& - & pqsen(klon,klev), pqte(klon,klev),& - & pverv(klon,klev), pqsenh(klon,klev) - real ptu(klon,klev), pqu(klon,klev),& - & puu(klon,klev), pvu(klon,klev),& - & pmfu(klon,klev), zph(klon),& - & pmfub(klon), & - & pmfus(klon,klev), pmfuq(klon,klev),& - & plu(klon,klev), plude(klon,klev),& - & pmful(klon,klev), pdmfup(klon,klev) - real zdmfen(klon), zdmfde(klon),& - & zmfuu(klon), zmfuv(klon),& - & zpbase(klon), zqold(klon) - real phcbase(klon), zluold(klon) - real zprecip(klon), zlrain(klon,klev) - real zbuo(klon,klev), kup(klon,klev) - real wup(klon) - real wbase(klon), zodetr(klon,klev) - real plglac(klon,klev) - - real eta(klon),dz(klon) - - integer klwmin(klon), ktype(klon),& - & klab(klon,klev), kcbot(klon),& - & kctop(klon), kctop0(klon) - integer lndj(klon) - logical ldcum(klon), loflag(klon) - logical llo2,llo3, llo1(klon) - - integer kdpl(klon) - real zoentr(klon), zdpmean(klon) - real pdmfen(klon,klev), pmfude_rate(klon,klev) -! local variables - integer jl,jk - integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll - integer jlx(klon) - real ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 - real zmftest,zmfmax,zqeen,zseen,zscde,zqude - real zmfusk,zmfuqk,zmfulk - real zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco - real zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold - real zrnew,zz,zdmfeu,zdmfdu,dp - real zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd - real atop1,atop2,abot -!-------------------------------- -!* 1. specify parameters -!-------------------------------- - zcons2=3./(g*ztmst) - zfacbuo = 0.5/(1.+0.5) - zprcdgw = cprcon*zrg - z_cldmax = 5.e-3 - z_cwifrac = 0.5 - z_cprc2 = 0.5 - z_cwdrag = (3.0/8.0)*0.506/0.2 -!--------------------------------- -! 2. set default values -!--------------------------------- - llo3 = .false. - do jl=1,klon - zluold(jl)=0. - wup(jl)=0. - zdpmean(jl)=0. - zoentr(jl)=0. - if(.not.ldcum(jl)) then - ktype(jl)=0 - kcbot(jl) = -1 - pmfub(jl) = 0. - pqu(jl,klev) = 0. - end if - end do - - ! initialize variout quantities - do jk=1,klev - do jl=1,klon - if(jk.ne.kcbot(jl)) plu(jl,jk)=0. - pmfu(jl,jk)=0. - pmfus(jl,jk)=0. - pmfuq(jl,jk)=0. - pmful(jl,jk)=0. - plude(jl,jk)=0. - plglac(jl,jk)=0. - pdmfup(jl,jk)=0. - zlrain(jl,jk)=0. - zbuo(jl,jk)=0. - kup(jl,jk)=0. - pdmfen(jl,jk) = 0. - pmfude_rate(jl,jk) = 0. - if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 - if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk - end do - end do - - do jl = 1,klon - if ( ktype(jl) == 3 ) ldcum(jl) = .false. - end do -!------------------------------------------------ -! 3.0 initialize values at cloud base level -!------------------------------------------------ - do jl=1,klon - kctop(jl)=kcbot(jl) - if(ldcum(jl)) then - ikb = kcbot(jl) - kup(jl,ikb) = 0.5*wbase(jl)**2 - pmfu(jl,ikb) = pmfub(jl) - pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) - pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) - pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) - end if - end do -! -!----------------------------------------------------------------- -! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) -! by doing first dry-adiabatic ascent and then -! by adjusting t,q and l accordingly in *cuadjtqn*, -! then check for buoyancy and set flags accordingly -!----------------------------------------------------------------- -! - do jk=klevm1,3,-1 -! specify cloud base values for midlevel convection -! in *cubasmc* in case there is not already convection -! --------------------------------------------------------------------- - ik=jk - call cubasmcn& - & (klon, klev, klevm1, ik, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup ) - is = 0 - jlm = 0 - do jl = 1,klon - loflag(jl) = .false. - zprecip(jl) = 0. - llo1(jl) = .false. - is = is + klab(jl,jk+1) - if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 - if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & - (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then - loflag(jl) = .true. - jlm = jlm + 1 - jlx(jlm) = jl - end if - zph(jl) = paph(jl,jk) - if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfub(jl) > zmfmax ) then - zfac = zmfmax/pmfub(jl) - pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac - pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac - pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac - pmfub(jl) = zmfmax - end if - pmfub(jl)=min(pmfub(jl),zmfmax) - end if - end do - - if(is.gt.0) llo3 = .true. -! -!* specify entrainment rates in *cuentr* -! ------------------------------------- - ik=jk - call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & - pgeoh,pmfu,zdmfen,zdmfde) -! -! do adiabatic ascent for entraining/detraining plume - if(llo3) then -! ------------------------------------------------------- -! - do jl = 1,klon - zqold(jl) = 0. - end do - do jll = 1 , jlm - jl = jlx(jll) - zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) - if ( jk == kcbot(jl) ) then - zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & - 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) - end if - if ( jk < kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - zxs = max(pmfu(jl,jk+1)-zmfmax,0.) - wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) - zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) - zdmfen(jl) = zoentr(jl) - if ( ktype(jl) >= 2 ) then - zdmfen(jl) = 2.0*zdmfen(jl) - zdmfde(jl) = zdmfen(jl) - end if - zdmfde(jl) = zdmfde(jl) * & - (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) - zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zchange = max(zmftest-zmfmax,0.) - zxe = max(zchange-zxs,0.) - zdmfen(jl) = zdmfen(jl) - zxe - zchange = zchange - zxe - zdmfde(jl) = zdmfde(jl) + zchange - end if - pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zqeen = pqenh(jl,jk+1)*zdmfen(jl) - zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) - zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) - zqude = pqu(jl,jk+1)*zdmfde(jl) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - zmfusk = pmfus(jl,jk+1) + zseen - zscde - zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude - zmfulk = pmful(jl,jk+1) - plude(jl,jk) - plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) - pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) - ptu(jl,jk) = (zmfusk * & - (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd - ptu(jl,jk) = max(100.,ptu(jl,jk)) - ptu(jl,jk) = min(400.,ptu(jl,jk)) - zqold(jl) = pqu(jl,jk) - zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & - (1./max(cmfcmin,pmfu(jl,jk))) - zluold(jl) = plu(jl,jk) - end do -! reset to environmental values if below departure level - do jl = 1,klon - if ( jk > kdpl(jl) ) then - ptu(jl,jk) = ptenh(jl,jk) - pqu(jl,jk) = pqenh(jl,jk) - plu(jl,jk) = 0. - zluold(jl) = plu(jl,jk) - end if - end do -!* do corrections for moist ascent -!* by adjusting t,q and l in *cuadjtq* -!------------------------------------------------ - ik=jk - icall=1 -! - if ( jlm > 0 ) then - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - end if -! compute the upfraft speed in cloud layer - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - plglac(jl,jk) = plu(jl,jk) * & - ((1.-foealfa(ptu(jl,jk)))- & - (1.-foealfa(ptu(jl,jk+1)))) - ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - klab(jl,jk) = 2 - plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) - zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & - zlrain(jl,jk+1)) - zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = zbc - zbe -! set flags for the case of midlevel convection - if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then - if ( zbuo(jl,jk) > -0.5 ) then - ldcum(jl) = .true. - kctop(jl) = jk - kup(jl,jk) = 0.5 - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - plude(jl,jk) = 0. - plu(jl,jk) = 0. - end if - end if - if ( klab(jl,jk+1) == 2 ) then - if ( zbuo(jl,jk) < 0. ) then - ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) - pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) - zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - end if - zbuoc = (zbuo(jl,jk) / & - (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & - (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 - zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc -! mixing and "pressure" gradient term in upper troposphere - if ( zdmfen(jl) > 0. ) then - zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - else - zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - end if - kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & - (1.+zdken) - if ( zbuo(jl,jk) < 0. ) then - zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) - zkedke = max(0.,min(1.,zkedke)) - zmfun = sqrt(zkedke)*pmfu(jl,jk+1) - zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - end if - if ( zbuo(jl,jk) > -0.2 ) then - ikb = kcbot(jl) - zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & - pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & - zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) - else - zoentr(jl) = 0. - end if -! erase values if below departure level - if ( jk > kdpl(jl) ) then - pmfu(jl,jk) = pmfu(jl,jk+1) - kup(jl,jk) = 0.5 - end if - if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then - kctop(jl) = jk - llo1(jl) = .true. - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - end if -! save detrainment rates for updraught - if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) - end if - else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfude_rate(jl,jk) = zdmfde(jl) - end if - end do - - do jl = 1,klon - if ( llo1(jl) ) then -! conversions only proceeds if plu is greater than a threshold liquid water -! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation -! generation from small water contents. - if ( lndj(jl).eq.1 ) then - zdshrd = 5.e-4 - else - zdshrd = 3.e-4 - end if - ikb=kcbot(jl) - if ( plu(jl,jk) > zdshrd )then - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) - zprcon = zprcdgw/(0.75*zwu) -! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) - zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) - zcbf = 1. + z_cprc2*sqrt(zdt) - zzco = zprcon*zcbf - zlcrit = zdshrd/zcbf - zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) - zc = (plu(jl,jk)-zluold(jl)) - zarg = (plu(jl,jk)/zlcrit)**2 - if ( zarg < 25.0 ) then - zd = zzco*(1.-exp(-zarg))*zdfi - else - zd = zzco*zdfi - end if - zint = exp(-zd) - zlnew = zluold(jl)*zint + zc/zd*(1.-zint) - zlnew = max(0.,min(plu(jl,jk),zlnew)) - zlnew = min(z_cldmax,zlnew) - zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) - pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) - zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) - plu(jl,jk) = zlnew - end if - end if - end do - do jl = 1, klon - if ( llo1(jl) ) then - if ( zlrain(jl,jk) > 0. ) then - zvw = 21.18*zlrain(jl,jk)**0.2 - zvi = z_cwifrac*zvw - zalfaw = foealfa(ptu(jl,jk)) - zvv = zalfaw*zvw + (1.-zalfaw)*zvi - zrold = zlrain(jl,jk) - zprecip(jl) - zc = zprecip(jl) - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) - zd = zvv/zwu - zint = exp(-zd) - zrnew = zrold*zint + zc/zd*(1.-zint) - zrnew = max(0.,min(zlrain(jl,jk),zrnew)) - zlrain(jl,jk) = zrnew - end if - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) - pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) - pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) - end do - end if - end do -!---------------------------------------------------------------------- -! 5. final calculations -! ------------------ - do jl = 1,klon - if ( kctop(jl) == -1 ) ldcum(jl) = .false. - kcbot(jl) = max(kcbot(jl),kctop(jl)) - if ( ldcum(jl) ) then - wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) - wup(jl) = sqrt(2.*wup(jl)) - end if - end do - - return - end subroutine cuascn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudlfsn & - & (klon, klev, & - & kcbot, kctop, lndj, ldcum, & - & ptenh, pqenh, puen, pven, & - & pten, pqsen, pgeo, & - & pgeoh, paph, ptu, pqu, plu,& - & puu, pvu, pmfub, prfl, & - & ptd, pqd, pud, pvd, & - & pmfd, pmfds, pmfdq, pdmfdp, & - & kdtop, lddraf) - -! this routine calculates level of free sinking for -! cumulus downdrafts and specifies t,q,u and v values - -! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 - -! purpose. -! -------- -! to produce lfs-values for cumulus downdrafts -! for massflux cumulus parameterization - -! interface -! --------- -! this routine is called from *cumastr*. -! input are environmental values of t,q,u,v,p,phi -! and updraft values t,q,u and v and also -! cloud base massflux and cu-precipitation rate. -! it returns t,q,u and v values and massflux at lfs. - -! method. - -! check for negative buoyancy of air of equal parts of -! moist environmental air and cloud air. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pten* provisional environment temperature (t+1) k -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *ptu* temperature in updrafts k -! *pqu* spec. humidity in updrafts kg/kg -! *plu* liquid water content in updrafts kg/kg -! *puu* u-velocity in updrafts m/s -! *pvu* v-velocity in updrafts m/s -! *pmfub* massflux in updrafts at cloud base kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! output parameters (integer): - -! *kdtop* top level of downdrafts - -! output parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! externals -! --------- -! *cuadjtq* for calculating wet bulb t and q at lfs -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pten(klon,klev), pqsen(klon,klev), & - & pgeo(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1),& - & ptu(klon,klev), pqu(klon,klev), & - & puu(klon,klev), pvu(klon,klev), & - & plu(klon,klev), & - & pmfub(klon), prfl(klon) - - real ptd(klon,klev), pqd(klon,klev), & - & pud(klon,klev), pvd(klon,klev), & - & pmfd(klon,klev), pmfds(klon,klev), & - & pmfdq(klon,klev), pdmfdp(klon,klev) - integer kcbot(klon), kctop(klon), & - & kdtop(klon), ikhsmin(klon) - logical ldcum(klon), & - & lddraf(klon) - integer lndj(klon) - - real ztenwb(klon,klev), zqenwb(klon,klev), & - & zcond(klon), zph(klon), & - & zhsmin(klon) - logical llo2(klon) -! local variables - integer jl,jk - integer is,ik,icall,ike - real zhsk,zttest,zqtest,zbuo,zmftop - -!---------------------------------------------------------------------- - -! 1. set default values for downdrafts -! --------------------------------- - do jl=1,klon - lddraf(jl)=.false. - kdtop(jl)=klev+1 - ikhsmin(jl)=klev+1 - zhsmin(jl)=1.e8 - enddo -!---------------------------------------------------------------------- - -! 2. determine level of free sinking: -! downdrafts shall start at model level of minimum -! of saturation moist static energy or below -! respectively - -! for every point and proceed as follows: - -! (1) determine level of minimum of hs -! (2) determine wet bulb environmental t and q -! (3) do mixing with cumulus cloud air -! (4) check for negative buoyancy -! (5) if buoyancy>0 repeat (2) to (4) for next -! level below - -! the assumption is that air of downdrafts is mixture -! of 50% cloud air + 50% environmental air at wet bulb -! temperature (i.e. which became saturated due to -! evaporation of rain and cloud water) -! ---------------------------------------------------- - do jk=3,klev-2 - do jl=1,klon - zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & - & foelhm(pten(jl,jk))*pqsen(jl,jk) - if(zhsk .lt. zhsmin(jl)) then - zhsmin(jl) = zhsk - ikhsmin(jl)= jk - end if - end do - end do - - - ike=klev-3 - do jk=3,ike - -! 2.1 calculate wet-bulb temperature and moisture -! for environmental air in *cuadjtq* -! ------------------------------------------- - is=0 - do jl=1,klon - ztenwb(jl,jk)=ptenh(jl,jk) - zqenwb(jl,jk)=pqenh(jl,jk) - zph(jl)=paph(jl,jk) - llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & - & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) - if(llo2(jl))then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - ik=jk - icall=2 - call cuadjtqn & - & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) - -! 2.2 do mixing of cumulus and environmental air -! and check for negative buoyancy. -! then set values for downdraft at lfs. -! ---------------------------------------- - do jl=1,klon - if(llo2(jl)) then - zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) - zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) - zbuo=zttest*(1.+vtmpc1 *zqtest)- & - & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) - zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) - zmftop=-cmfdeps*pmfub(jl) - if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then - kdtop(jl)=jk - lddraf(jl)=.true. - ptd(jl,jk)=zttest - pqd(jl,jk)=zqtest - pmfd(jl,jk)=zmftop - pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) - pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) - pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) - prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) - endif - endif - enddo - - enddo - - return - end subroutine cudlfsn - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- -!********************************************** -! subroutine cuddrafn -!********************************************** - subroutine cuddrafn & - & ( klon, klev, lddraf & - & , ptenh, pqenh, puen, pven & - & , pgeo, pgeoh, paph, prfl & - & , ptd, pqd, pud, pvd, pmfu & - & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) - -! this routine calculates cumulus downdraft descent - -! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 - -! purpose. -! -------- -! to produce the vertical profiles for cumulus downdrafts -! (i.e. t,q,u and v and fluxes) - -! interface -! --------- - -! this routine is called from *cumastr*. -! input is t,q,p,phi,u,v at half levels. -! it returns fluxes of s,q and evaporation rate -! and u,v at levels where downdraft occurs - -! method. -! -------- -! calculate moist descent for entraining/detraining plume by -! a) moving air dry-adiabatically to next level below and -! b) correcting for evaporation to obtain saturated state. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels - -! input parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *pmfu* massflux updrafts kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! externals -! --------- -! *cuadjtq* for adjusting t and q due to evaporation in -! saturated descent -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1), & - & pgeo(klon,klev), pmfu(klon,klev) - - real ptd(klon,klev), pqd(klon,klev), & - & pud(klon,klev), pvd(klon,klev), & - & pmfd(klon,klev), pmfds(klon,klev), & - & pmfdq(klon,klev), pdmfdp(klon,klev), & - & prfl(klon) - real pmfdde_rate(klon,klev) - logical lddraf(klon) - - real zdmfen(klon), zdmfde(klon), & - & zcond(klon), zoentr(klon), & - & zbuoy(klon) - real zph(klon) - logical llo2(klon) - logical llo1 -! local variables - integer jl,jk - integer is,ik,icall,ike, itopde(klon) - real zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp - real zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk - -!---------------------------------------------------------------------- -! 1. calculate moist descent for cumulus downdraft by -! (a) calculating entrainment/detrainment rates, -! including organized entrainment dependent on -! negative buoyancy and assuming -! linear decrease of massflux in pbl -! (b) doing moist descent - evaporative cooling -! and moistening is calculated in *cuadjtq* -! (c) checking for negative buoyancy and -! specifying final t,q,u,v and downward fluxes -! ------------------------------------------------- - do jl=1,klon - zoentr(jl)=0. - zbuoy(jl)=0. - zdmfen(jl)=0. - zdmfde(jl)=0. - enddo - - do jk=klev,1,-1 - do jl=1,klon - pmfdde_rate(jl,jk) = 0. - if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk - end do - end do - - do jk=3,klev - is=0 - do jl=1,klon - zph(jl)=paph(jl,jk) - llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. - if(llo2(jl)) then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - do jl=1,klon - if(llo2(jl)) then - zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zdmfen(jl)=zentr - zdmfde(jl)=zentr - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.gt.itopde(jl)) then - zdmfen(jl)=0. - zdmfde(jl)=pmfd(jl,itopde(jl))* & - & (paph(jl,jk)-paph(jl,jk-1))/ & - & (paph(jl,klev+1)-paph(jl,itopde(jl))) - endif - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.le.itopde(jl)) then - zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) - zdmfen(jl)=zdmfen(jl)+zzentr - zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) - zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & - & (pmfd(jl,jk-1)-zdmfde(jl))) - zdmfen(jl)=min(zdmfen(jl),0.) - endif - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) - zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) - zqeen=pqenh(jl,jk-1)*zdmfen(jl) - zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) - zqdde=pqd(jl,jk-1)*zdmfde(jl) - zmfdsk=pmfds(jl,jk-1)+zseen-zsdde - zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde - pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) - ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& - & pgeoh(jl,jk))*rcpd - ptd(jl,jk)=min(400.,ptd(jl,jk)) - ptd(jl,jk)=max(100.,ptd(jl,jk)) - zcond(jl)=pqd(jl,jk) - endif - enddo - - ik=jk - icall=2 - call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) - - do jl=1,klon - if(llo2(jl)) then - zcond(jl)=zcond(jl)-pqd(jl,jk) - zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & - & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) - if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then - zrain=prfl(jl)/pmfu(jl,jk) - zbuo=zbuo-ptd(jl,jk)*zrain - endif - if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then - pmfd(jl,jk)=0. - zbuo=0. - endif - pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) - pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) - zdmfdp=-pmfd(jl,jk)*zcond(jl) - pdmfdp(jl,jk-1)=zdmfdp - prfl(jl)=prfl(jl)+zdmfdp - -! compute organized entrainment for use at next level - zbuoyz=zbuo/ptenh(jl,jk) - zbuoyz=min(zbuoyz,0.0) - zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) - zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz - zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) - pmfdde_rate(jl,jk) = -zdmfde(jl) - endif - enddo - - enddo - - return - end subroutine cuddrafn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ptenh, pqenh & - & , paph, pap, pgeoh, lndj, ldcum & - & , kcbot, kctop, kdtop, ktopm2 & - & , ktype, lddraf & - & , pmfu, pmfd, pmfus, pmfds & - & , pmfuq, pmfdq, pmful, plude & - & , pdmfup, pdmfdp, pdpmel, plglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 - -! purpose -! ------- - -! this routine does the final calculation of convective -! fluxes in the cloud layer and in the subcloud layer - -! interface -! --------- -! this routine is called from *cumastr*. - - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level -! *kdtop* top level of downdrafts - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptsphy* time step for the physics s -! *pten* provisional environment temperature (t+1) k -! *pqen* provisional environment spec. humidity (t+1) kg/kg -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *paph* provisional pressure on half levels pa -! *pap* provisional pressure on full levels pa -! *pgeoh* geopotential on half levels m2/s2 - -! updated parameters (integer): - -! *ktype* set to zero if ldcum=.false. - -! updated parameters (logical): - -! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) - if ( llddraf .and.jk.ge.kdtop(jl)) then - pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & - (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) - pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) - else - pmfd(jl,jk) = 0. - pmfds(jl,jk) = 0. - pmfdq(jl,jk) = 0. - pdmfdp(jl,jk-1) = 0. - end if - if ( llddraf .and. pmfd(jl,jk) < 0. .and. & - abs(pmfd(jl,ikb)) < 1.e-20 ) then - idbas(jl) = jk - end if - else - pmfu(jl,jk)=0. - pmfd(jl,jk)=0. - pmfus(jl,jk)=0. - pmfds(jl,jk)=0. - pmfuq(jl,jk)=0. - pmfdq(jl,jk)=0. - pmful(jl,jk)=0. - plglac(jl,jk)=0. - pdmfup(jl,jk-1)=0. - pdmfdp(jl,jk-1)=0. - plude(jl,jk-1)=0. - endif - enddo - enddo - - do jl=1,klon - pmflxr(jl,klev+1) = 0. - pmflxs(jl,klev+1) = 0. - end do - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - ik=ikb+1 - zzp=((paph(jl,klev+1)-paph(jl,ik))/ & - & (paph(jl,klev+1)-paph(jl,ikb))) - if(ktype(jl).eq.3) then - zzp=zzp**2 - endif - pmfu(jl,ik)=pmfu(jl,ikb)*zzp - pmfus(jl,ik)=(pmfus(jl,ikb)- & - & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp - pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp - pmful(jl,ik)=0. - endif - enddo - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then - ikb=kcbot(jl)+1 - zzp=((paph(jl,klev+1)-paph(jl,jk))/ & - & (paph(jl,klev+1)-paph(jl,ikb))) - if(ktype(jl).eq.3) then - zzp=zzp**2 - endif - pmfu(jl,jk)=pmfu(jl,ikb)*zzp - pmfus(jl,jk)=pmfus(jl,ikb)*zzp - pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp - pmful(jl,jk)=0. - endif - ik = idbas(jl) - llddraf = lddraf(jl) .and. jk > ik .and. ik < klev - if ( llddraf .and. ik == kcbot(jl)+1 ) then - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - pmfd(jl,jk) = pmfd(jl,ik)*zzp - pmfds(jl,jk) = pmfds(jl,ik)*zzp - pmfdq(jl,jk) = pmfdq(jl,ik)*zzp - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - end if - enddo - enddo -!* 2. calculate rain/snow fall rates -!* calculate melting of snow -!* calculate evaporation of precip -! ------------------------------- - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then - prain(jl)=prain(jl)+pdmfup(jl,jk) - if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then - zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) - zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) - zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) - pdpmel(jl,jk)=zsnmlt - pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) - endif - zalfaw=foealfa(pten(jl,jk)) - ! - ! No liquid precipitation above melting level - ! - if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then - plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) - zalfaw = 0. - end if - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) - pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) - if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then - pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdpmel(jl,jk) =0.0 - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - endif - enddo - enddo - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.ge.kcbot(jl)) then - zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) - if(zrfl.gt.1.e-20) then - zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & - & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & - & zrfl/zcucov)**0.5777* & - & (paph(jl,jk+1)-paph(jl,jk)) - zrnew=zrfl-zdrfl1 - zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & - & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) - zrnew=max(zrnew,zrmin) - zrfln=max(zrnew,0.) - zdrfl=min(0.,zrfln-zrfl) - zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) - zalfaw=foealfa(pten(jl,jk)) - if ( pten(jl,jk) < tmelt ) zalfaw = 0. - zpdr=zalfaw*pdmfdp(jl,jk) - zpds=(1.-zalfaw)*pdmfdp(jl,jk) - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & - & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom - pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & - & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom - pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl - if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then - pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) - pmflxr(jl,jk+1) = 0. - pmflxs(jl,jk+1) = 0. - pdpmel(jl,jk) = 0. - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - else - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdmfdp(jl,jk)=0.0 - pdpmel(jl,jk)=0.0 - endif - endif - enddo - enddo - - return - end subroutine cuflxn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & - lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & - pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & - pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) - implicit none - integer klon,klev,ktopm2 - integer kctop(klon), kdtop(klon) - logical ldcum(klon), lddraf(klon) - real ztmst - real paph(klon,klev+1), pgeoh(klon,klev+1) - real pgeo(klon,klev), pten(klon,klev), & - pqen(klon,klev), ptenh(klon,klev),& - pqenh(klon,klev), pqsen(klon,klev),& - plglac(klon,klev), plude(klon,klev) - real pmfu(klon,klev), pmfd(klon,klev),& - pmfus(klon,klev), pmfds(klon,klev),& - pmfuq(klon,klev), pmfdq(klon,klev),& - pmful(klon,klev), pdmfup(klon,klev),& - pdpmel(klon,klev), pdmfdp(klon,klev) - real ptent(klon,klev), ptenq(klon,klev) - real pcte(klon,klev) - -! local variables - integer jk , ik , jl - real zalv , zzp - real zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) - !* 1.0 SETUP AND INITIALIZATIONS - ! ------------------------- - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - end if - end do - end do - !----------------------------------------------------------------------- - !* 2.0 COMPUTE TENDENCIES - ! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & - (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & - pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) - zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & - pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & - pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & - (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) - zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & - pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) - end if - end do - end if - end do - !--------------------------------------------------------------- - !* 3.0 UPDATE TENDENCIES - ! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) - ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) - pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) - end if - end do - end do - - return - end subroutine cudtdqn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & - ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & - ptenv) - implicit none - integer klon,klev,ktopm2 - integer ktype(klon), kcbot(klon), kctop(klon) - logical ldcum(klon) - real ztmst - real paph(klon,klev+1) - real puen(klon,klev), pven(klon,klev),& - pmfu(klon,klev), pmfd(klon,klev),& - puu(klon,klev), pud(klon,klev),& - pvu(klon,klev), pvd(klon,klev) - real ptenu(klon,klev), ptenv(klon,klev) - -!local variables - real zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & - zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) - - integer ik , ikb , jk , jl - real zzp, zdtdt - - real zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) -! - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zuen(jl,jk) = puen(jl,jk) - zven(jl,jk) = pven(jl,jk) - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - end if - end do - end do -!---------------------------------------------------------------------- -!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES -! ---------------------------------------------- - do jk = ktopm2 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) - zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) - zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) - zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) - end if - end do - end do - ! linear fluxes below cloud - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk > kcbot(jl) ) then - ikb = kcbot(jl) - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp - zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp - zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp - zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp - end if - end do - end do -!---------------------------------------------------------------------- -!* 2.0 COMPUTE TENDENCIES -! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = zdp(jl,jk) * & - (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) - zdvdt(jl,jk) = zdp(jl,jk) * & - (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) - zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) - end if - end do - end if - end do -!--------------------------------------------------------------------- -!* 3.0 UPDATE TENDENCIES -! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) - ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) - end if - end do - end do -!---------------------------------------------------------------------- - return - end subroutine cududvn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuadjtqn & - & (klon, klev, kk, psp, pt, pq, ldflag, kcall) -! m.tiedtke e.c.m.w.f. 12/89 -! purpose. -! -------- -! to produce t,q and l values for cloud ascent - -! interface -! --------- -! this routine is called from subroutines: -! *cond* (t and q at condensation level) -! *cubase* (t and q at condensation level) -! *cuasc* (t and q at cloud levels) -! *cuini* (environmental t and qs values at half levels) -! input are unadjusted t and q values, -! it returns adjusted values of t and q - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kk* level -! *kcall* defines calculation as -! kcall=0 env. t and qs in*cuini* -! kcall=1 condensation in updrafts (e.g. cubase, cuasc) -! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) -! input parameters (real): - -! *psp* pressure pa - -! updated parameters (real): - -! *pt* temperature k -! *pq* specific humidity kg/kg -! externals -! --------- -! for condensation calculations. -! the tables are initialised in *suphec*. - -!---------------------------------------------------------------------- - - implicit none - - integer klev,klon - real pt(klon,klev), pq(klon,klev), & - & psp(klon) - logical ldflag(klon) -! local variables - integer jl,jk - integer isum,kcall,kk - real zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf -!---------------------------------------------------------------------- -! 1. define constants -! ---------------- - zqmax=0.5 - -! 2. calculate condensation and adjust t and q accordingly -! ----------------------------------------------------- - - if ( kcall == 1 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & - (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( zcond > 0. ) then - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk)) * & - exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & - exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( abs(zcond) < 1.e-20 ) zcond1 = 0. - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end if - end do - elseif ( kcall == 2 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - zcond = min(zcond,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end do - else if ( kcall == 0 ) then - do jl = 1,klon - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end do - end if - - return - end subroutine cuadjtqn -!--------------------------------------------------------- -! level 4 souroutines -!-------------------------------------------------------- - subroutine cubasmcn & - & (klon, klev, klevm1, kk, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, plrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup ) - implicit none -! m.tiedtke e.c.m.w.f. 12/89 -! c.zhang iprc 05/2012 -!***purpose. -! -------- -! this routine calculates cloud base values -! for midlevel convection -!***interface -! --------- -! this routine is called from *cuasc*. -! input are environmental values t,q etc -! it returns cloudbase values for midlevel convection -!***method. -! ------- -! s. tiedtke (1989) -!***externals -! --------- -! none -! ---------------------------------------------------------------- - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & pqsen(klon,klev), pverv(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klev+1) - real ptu(klon,klev), pqu(klon,klev),& - & puu(klon,klev), pvu(klon,klev),& - & plu(klon,klev), pmfu(klon,klev),& - & pmfub(klon), & - & pmfus(klon,klev), pmfuq(klon,klev),& - & pmful(klon,klev), pdmfup(klon,klev),& - & plrain(klon,klev) - integer ktype(klon), kcbot(klon),& - & klab(klon,klev) - logical ldcum(klon) -! local variabels - integer jl,kk,klev,klon,klevp1,klevm1 - real zzzmb -!-------------------------------------------------------- -!* 1. calculate entrainment and detrainment rates -! ------------------------------------------------------- - do jl=1,klon - if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then - if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & - pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & - & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then - ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& - & *rcpd - pqu(jl,kk+1)=pqen(jl,kk) - plu(jl,kk+1)=0. - zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) - zzzmb=min(zzzmb,cmfcmax) - pmfub(jl)=zzzmb - pmfu(jl,kk+1)=pmfub(jl) - pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) - pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) - pmful(jl,kk+1)=0. - pdmfup(jl,kk+1)=0. - kcbot(jl)=kk - klab(jl,kk+1)=1 - plrain(jl,kk+1)=0.0 - ktype(jl)=3 - end if - end if - end do - return - end subroutine cubasmcn -!--------------------------------------------------------- -! level 4 souroutines -!--------------------------------------------------------- - subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & - pgeoh,pmfu,pdmfen,pdmfde) - implicit none - integer klon,klev,kk - integer kcbot(klon) - logical ldcum(klon) - logical ldwork - real pgeoh(klon,klev+1) - real pmfu(klon,klev) - real pdmfen(klon) - real pdmfde(klon) - logical llo1 - integer jl - real zdz , zmf - real zentr(klon) - ! - !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES - ! ------------------------------------------- - if ( ldwork ) then - do jl = 1,klon - pdmfen(jl) = 0. - pdmfde(jl) = 0. - zentr(jl) = 0. - end do - ! - !* 1.1 SPECIFY ENTRAINMENT RATES - ! ------------------------- - do jl = 1, klon - if ( ldcum(jl) ) then - zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg - zmf = pmfu(jl,kk+1)*zdz - llo1 = kk < kcbot(jl) - if ( llo1 ) then - pdmfen(jl) = zentr(jl)*zmf - pdmfde(jl) = 0.75e-4*zmf - end if - end if - end do - end if - end subroutine cuentrn -!-------------------------------------------------------- -! external functions -!------------------------------------------------------ - real function foealfa(tt) -! foealfa is calculated to distinguish the three cases: -! -! foealfa=1 water phase -! foealfa=0 ice phase -! 0 < foealfa < 1 mixed phase -! -! input : tt = temperature -! - implicit none - real tt - foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & - & /(rtwat-rtice))**2) - - return - end function foealfa - - real function foelhm(tt) - implicit none - real tt - foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als - return - end function foelhm - - real function foeewm(tt) - implicit none - real tt - foeewm = c2es * & - & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & - & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) - return - end function foeewm - - real function foedem(tt) - implicit none - real tt - foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & - & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) - return - end function foedem - - real function foeldcpm(tt) - implicit none - real tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm - -end module module_cu_ntiedtke - + endif + endif + + enddo + + end subroutine cu_ntiedtke_driver + +!================================================================================================================= + subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & + rucuten,rvcuten,rthften,rqvften, & + restart,p_qc,p_qi,p_first_scalar, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: allowed_to_read,restart + + integer,intent(in):: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + integer,intent(in):: p_first_scalar,p_qi,p_qc + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,rthften,rqvften + +!--- local variables and arrays: + integer:: i,j,k,itf,jtf,ktf + +!----------------------------------------------------------------------------------------------------------------- + + jtf = min0(jte,jde-1) + ktf = min0(kte,kde-1) + itf = min0(ite,ide-1) + + if(.not.restart)then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rthcuten(i,k,j) = 0. + rqvcuten(i,k,j) = 0. + rucuten(i,k,j) = 0. + rvcuten(i,k,j) = 0. + enddo + enddo + enddo + + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rthften(i,k,j)=0. + rqvften(i,k,j)=0. + enddo + enddo + enddo + + if(p_qc .ge. p_first_scalar) then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rqccuten(i,k,j)=0. + enddo + enddo + enddo + endif + + if(p_qi .ge. p_first_scalar) then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rqicuten(i,k,j)=0. + enddo + enddo + enddo + endif + endif + + end subroutine ntiedtkeinit + +!================================================================================================================= + subroutine cu_ntiedtke_pre_run(its,ite,kts,kte,im,kx,kx1,itimestep,stepcu,dt,grav,xland,dz,pres,presi, & + t,rho,qv,qc,qi,u,v,w,qvften,thften,qvftenz,thftenz,slimsk,delt,prsl,ghtl, & + tf,qvf,qcf,qif,uf,vf,prsi,ghti,omg,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: itimestep + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt,grav + real(kind=kind_phys),intent(in),dimension(its:ite):: xland + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: dz,pres,t,rho,qv,qc,qi,u,v + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvften,thften + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte+1):: presi,w + +!--- inout arguments: + integer,intent(inout):: im,kx,kx1 + integer,intent(inout),dimension(its:ite):: slimsk + + real(kind=kind_phys),intent(inout):: delt + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: tf,qvf,qcf,qif,uf,vf + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: ghtl,omg,prsl + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte+1):: ghti,prsi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys),dimension(its:ite,kts:kte):: zl,dot + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: zi + +!----------------------------------------------------------------------------------------------------------------- + + im = ite-its+1 + kx = kte-kts+1 + kx1 = kx+1 + + delt = dt*stepcu + + do i = its,ite + slimsk(i) = (abs(xland(i)-2.)) + enddo + + k = kts + do i = its,ite + zi(i,k) = 0. + enddo + do k = kts,kte + do i = its,ite + zi(i,k+1) = zi(i,k)+dz(i,k) + enddo + enddo + do k = kts,kte + do i = its,ite + zl(i,k) = 0.5*(zi(i,k)+zi(i,k+1)) + dot(i,k) = -0.5*grav*rho(i,k)*(w(i,k)+w(i,k+1)) + enddo + enddo + + pp = 0 + do k = kts,kte+1 + zz = kte + 1 - pp + do i = its,ite + ghti(i,zz) = zi(i,k) + prsi(i,zz) = presi(i,k) + enddo + pp = pp + 1 + enddo + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + ghtl(i,zz) = zl(i,k) + omg(i,zz) = dot(i,k) + prsl(i,zz) = pres(i,k) + enddo + pp = pp + 1 + enddo + + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + tf(i,zz) = t(i,k) + qvf(i,zz) = qv(i,k) + qcf(i,zz) = qc(i,k) + qif(i,zz) = qi(i,k) + uf(i,zz) = u(i,k) + vf(i,zz) = v(i,k) + enddo + pp = pp + 1 + enddo + + if(itimestep == 1) then + do k = kts,kte + do i = its,ite + qvftenz(i,k) = 0. + thftenz(i,k) = 0. + enddo + enddo + else + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + qvftenz(i,zz) = qvften(i,k) + thftenz(i,zz) = thften(i,k) + enddo + pp = pp + 1 + enddo + endif + + errmsg = 'cu_ntiedtke_pre_run OK' + errflg = 0 + + end subroutine cu_ntiedtke_pre_run + +!================================================================================================================= + subroutine cu_ntiedtke_post_run(its,ite,kts,kte,stepcu,dt,exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf,rn,raincv, & + pratec,rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(its:ite):: rn + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: raincv,pratec + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rqvcuten,rqccuten,rqicuten + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rthcuten,rucuten,rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys):: delt,rdelt + +!----------------------------------------------------------------------------------------------------------------- + + delt = dt*stepcu + rdelt = 1./delt + + do i = its,ite + raincv(i) = rn(i)/stepcu + pratec(i) = rn(i)/(stepcu*dt) + enddo + + pp = 0 + do k = kts,kte + zz = kte - pp + do i = its,ite + rthcuten(i,k) = (tf(i,zz)-t(i,k))/exner(i,k)*rdelt + rqvcuten(i,k) = (qvf(i,zz)-qv(i,k))*rdelt + rqccuten(i,k) = (qcf(i,zz)-qc(i,k))*rdelt + rqicuten(i,k) = (qif(i,zz)-qi(i,k))*rdelt + rucuten(i,k) = (uf(i,zz)-u(i,k))*rdelt + rvcuten(i,k) = (vf(i,zz)-v(i,k))*rdelt + enddo + pp = pp + 1 + enddo + + errmsg = 'cu_ntiedtke_timestep_final OK' + errflg = 0 + + end subroutine cu_ntiedtke_post_run + +!================================================================================================================= + end module module_cu_ntiedtke +!================================================================================================================= diff --git a/phys/module_cumulus_driver.F b/phys/module_cumulus_driver.F index 305c32dde1..e1292a2d56 100644 --- a/phys/module_cumulus_driver.F +++ b/phys/module_cumulus_driver.F @@ -200,7 +200,7 @@ SUBROUTINE cumulus_driver(grid & USE module_cu_osas , ONLY : cu_osas USE module_cu_camzm_driver, ONLY : camzm_driver USE module_cu_tiedtke, ONLY : cu_tiedtke - USE module_cu_ntiedtke,ONLY : cu_ntiedtke + USE module_cu_ntiedtke,ONLY : cu_ntiedtke_driver USE module_cu_ksas , ONLY : cu_ksas USE module_cu_nsas , ONLY : cu_nsas USE module_wrf_error , ONLY : wrf_err_message @@ -744,6 +744,10 @@ SUBROUTINE cumulus_driver(grid & INTEGER, INTENT(IN) :: JULDAY #endif +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + !----------------------------------------------------------------- pattern_spp_conv=0. field_conv=0. @@ -1414,7 +1418,7 @@ SUBROUTINE cumulus_driver(grid & CASE (NTIEDTKESCHEME) CALL wrf_debug(100,'in cu_ntiedtke') - CALL CU_NTIEDTKE( & + CALL CU_NTIEDTKE_DRIVER( & DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU,HFX=hfx & ,RAINCV=RAINCV,PRATEC=tmppratec,QFX=qfx & ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & @@ -1431,6 +1435,9 @@ SUBROUTINE cumulus_driver(grid & ,RUCUTEN = RUCUTEN,RVCUTEN = RVCUTEN & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs & + ,GRAV=g,XLF=xlf,XLS=xls,XLV=xlv & + ,RD=r_d,RV=r_v,CP=cp & + ,errmsg=errmsg,errflg=errflg & ) ! New KIM SAS SCHEME - (KIAPS, South Korea) diff --git a/phys/module_diag_nwp.F b/phys/module_diag_nwp.F index 9879b496a7..336b0cd372 100644 --- a/phys/module_diag_nwp.F +++ b/phys/module_diag_nwp.F @@ -13,6 +13,7 @@ MODULE module_diag_nwp PRIVATE :: GAMMLN CONTAINS SUBROUTINE diagnostic_output_nwp( & + config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -44,15 +45,17 @@ SUBROUTINE diagnostic_output_nwp( & ) !---------------------------------------------------------------------- + USE module_configure, ONLY : grid_config_rec_type + USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, THOMPSONGH, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & - NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FULL_KHAIN_LYNN, MORR_TM_AERO, & - FAST_KHAIN_LYNN_SHPUND !,MILBRANDT3MOM, NSSL_3MOM + NSSL_2MOM, FAST_KHAIN_LYNN_SHPUND !,MILBRANDT3MOM USE MODULE_MP_THOMPSON, ONLY: idx_bg1 + IMPLICIT NONE !====================================================================== ! Definitions @@ -106,6 +109,10 @@ SUBROUTINE diagnostic_output_nwp( & ! !====================================================================== + ! We are not changing any of the namelist settings. + + TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -378,7 +385,7 @@ SUBROUTINE diagnostic_output_nwp( & !.. graupel category mixing ratio and number concentration (or hail, if !.. available). This diagnostic uses the actual spectral distribution !.. assumptions, calculated by breaking the distribution into 50 bins -!.. from 0.5mm to 7.5cm. Once a minimum number concentration of 0.01 +!.. from 0.5mm to 7.5cm. Once a minimum number concentration of thresh_conc (5e-4) !.. particle per cubic meter of air is reached, from the upper size !.. limit, then this bin is considered the max size. !+---+-----------------------------------------------------------------+ @@ -714,19 +721,26 @@ SUBROUTINE diagnostic_output_nwp( & ! CASE (MILBRANDT3MOM) ! coming in future? - CASE (NSSL_1MOMLFO, NSSL_1MOM, NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN) + CASE (NSSL_2MOM) +! Only treat 1-moment option here. 2- and 3-moment are now done in the microphysics +! + if ( config_flags%nssl_2moment_on == 0 ) then ! single-moment scheme_has_graupel = .true. xrho_g = nssl_rho_qh N0exp = nssl_cnoh - if (PRESENT(qh_curr)) then + if (config_flags%nssl_hail_on==1) then xrho_g = nssl_rho_qhl N0exp = nssl_cnohl endif xam_g = 3.1415926536/6.0*xrho_g - if (PRESENT(ng_curr)) xmu_g = nssl_alphah - if (PRESENT(nh_curr)) xmu_g = nssl_alphahl + + IF (config_flags%nssl_hail_on==1) THEN + xmu_g = nssl_alphahl + ELSE + xmu_g = nssl_alphah + ENDIF if (xmu_g .NE. 0.) then cge(1) = xbm_g + 1. @@ -736,11 +750,14 @@ SUBROUTINE diagnostic_output_nwp( & cgg(n) = WGAMMA(cge(n)) enddo endif + + ENDIF ! NSSL scheme has many options, but, if single-moment, just fill ! in the number array for graupel from built-in assumptions. - if (.NOT.(PRESENT(nh_curr).OR.PRESENT(ng_curr)) ) then +! if (.NOT.(PRESENT(nh_curr).OR.PRESENT(ng_curr)) ) then + if ( config_flags%nssl_2moment_on == 0 ) then ! single-moment ! !$OMP PARALLEL DO & ! !$OMP PRIVATE ( ij ) DO ij = 1 , num_tiles diff --git a/phys/module_diagnostics_driver.F b/phys/module_diagnostics_driver.F index 42c29f49d2..aa583b505f 100644 --- a/phys/module_diagnostics_driver.F +++ b/phys/module_diagnostics_driver.F @@ -39,9 +39,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, THOMPSONGH, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & - NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN_SHPUND, FULL_KHAIN_LYNN, & - MORR_TM_AERO !TWG add !,MILBRANDT3MOM, NSSL_3MOM, MORR_MILB_P3 + NSSL_2MOM, MORR_TM_AERO !TWG add !,MILBRANDT3MOM, MORR_MILB_P3 USE module_driver_constants, ONLY: max_plevs, max_zlevs @@ -410,9 +409,10 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & mp_select: SELECT CASE(config_flags%mp_physics) - CASE (LINSCHEME, WSM6SCHEME, WDM6SCHEME, GSFCGCESCHEME, NSSL_1MOMLFO) + CASE (LINSCHEME, WSM6SCHEME, WDM6SCHEME, GSFCGCESCHEME) - CALL diagnostic_output_nwp( & + CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -460,6 +460,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (THOMPSON, THOMPSONAERO) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -509,6 +510,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (THOMPSONGH) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -560,6 +562,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (MORR_TWO_MOMENT, MORR_TM_AERO) ! TWG add CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -605,57 +608,11 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,ADAPTIVE_TS=config_flags%use_adaptive_time_step & ) - CASE (NSSL_1MOM) - CALL diagnostic_output_nwp( & - U=grid%u_2 ,V=grid%v_2 & - ,TEMP=grid%t_phy ,P8W=p8w & - ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & - ,XTIME=grid%xtime & - ! Selection flag - ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn - ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn - ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn - ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn - ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn - ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn - ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn - ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn - ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn - ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn - ,CURR_SECS2=curr_secs2 & - ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & - ,DIAGFLAG=diag_flag & - ,HISTORY_INTERVAL=grid%history_interval & - ,ITIMESTEP=grid%itimestep & - ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & - ,WSPD10MAX=grid%wspd10max & - ,UP_HELI_MAX=grid%up_heli_max & - ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & - ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & - ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & - ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & - ,REFD_MAX=grid%refd_max & - ,refl_10cm=grid%refl_10cm & - ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn - ,QG_CURR=moist(ims,kms,jms,P_QG) & - ,QH_CURR=moist(ims,kms,jms,P_QH) & ! gthompsn - ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & - ! Dimension arguments - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & - ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & - ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & - ,KTS=k_start, KTE=min(k_end,kde-1) & - ,NUM_TILES=grid%num_tiles & - ,MAX_TIME_STEP=grid%max_time_step & - ,ADAPTIVE_TS=config_flags%use_adaptive_time_step & - ) - - CASE (MILBRANDT2MOM, NSSL_2MOM, NSSL_2MOMCCN) + CASE (MILBRANDT2MOM, NSSL_2MOM) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -715,8 +672,6 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ! CASE (ETAMPNEW) -! CASE (NSSL_3MOM) - ! CASE (MILBRANDT3MOM) ! CASE (MORR_MILB_P3) @@ -734,6 +689,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE DEFAULT CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & diff --git a/phys/module_fr_fire_atm.F b/phys/module_fr_fire_atm.F index 0cb3bfcf23..ac7acf5cae 100644 --- a/phys/module_fr_fire_atm.F +++ b/phys/module_fr_fire_atm.F @@ -21,7 +21,8 @@ subroutine add_fire_tracer_emissions( & its,ite,kts,kte,jts,jte, & rho,dz8w, & burnt_area_dt,fgip, & - tracer,fire_tracer_smoke & + tracer,fire_tracer_smoke, & + fire_smk_scheme,fire_smk_peak,fire_smk_ext,fire_tg_ub,zs,z_at_w & !for Truncated Gaussian dist. ) implicit none @@ -33,10 +34,23 @@ subroutine add_fire_tracer_emissions( & real,intent(in)::rho(ims:ime,kms:kme,jms:jme),dz8w(ims:ime,kms:kme,jms:jme) real,intent(in),dimension(ifms:ifme,jfms:jfme)::burnt_area_dt,fgip real,intent(inout)::tracer(ims:ime,kms:kme,jms:jme,num_tracer) + +integer, intent(in) :: fire_smk_scheme !switch for smoke release +real, intent(in) :: fire_smk_peak !peak smoke release height for TG +real, intent(in) :: fire_smk_ext !smoke extinction depth for TG +real, intent(in) :: fire_tg_ub !upper bound of TG +real, intent(in), dimension( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl +real, intent(in), dimension( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + ! local integer::isz1,jsz1,isz2,jsz2,ir,jr integer::i,j,ibase,jbase,i_f,ioff,j_f,joff real::avgw,emis,conv +integer :: i_st,i_en,j_st,j_en + +!local for TG +integer :: k,k_st,k_en +real, dimension(its:ite,kts:kte,jts:jte) :: prop_smk isz1 = ite-its+1 jsz1 = jte-jts+1 @@ -46,18 +60,44 @@ subroutine add_fire_tracer_emissions( & jr=jsz2/jsz1 avgw = 1.0/(ir*jr) -do j=max(jds+1,jts),min(jte,jde-2) +! --- set loop indicies +i_st = MAX(its,ids+1) +i_en = MIN(ite,ide-2) +j_st = MAX(jts,jds+1) +j_en = MIN(jte,jde-2) + +! --- check if TG used: init prop_smk +if (fire_smk_scheme .eq. 1) then + k_st = kts + k_en = MIN(kte,kde-1) + call tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_smk_peak,fire_tg_ub,fire_smk_ext,z_at_w,zs, & + prop_smk) +end if + +do j=j_st,j_en jbase=jtfs+jr*(j-jts) - do i=max(ids+1,its),min(ite,ide-2) + do i=i_st,i_st ibase=ifts+ir*(i-its) do joff=0,jr-1 j_f=joff+jbase do ioff=0,ir-1 i_f=ioff+ibase - if (num_tracer >0)then + if (num_tracer > 0)then + if (fire_smk_scheme .eq. 0)then emis=avgw*fire_tracer_smoke*burnt_area_dt(i_f,j_f)*fgip(i_f,j_f)*1000/(rho(i,kts,j)*dz8w(i,kts,j)) ! g_smoke/kg_air tracer(i,kts,j,p_fire_smoke)=tracer(i,kts,j,p_fire_smoke)+emis - endif + + else if (fire_smk_scheme .eq. 1)then + do k = k_st,k_en + emis=prop_smk(i,k,j)*avgw*fire_tracer_smoke*burnt_area_dt(i_f,j_f)*fgip(i_f,j_f)*1000/(rho(i,k,j)*dz8w(i,k,j)) ! g_smoke/kg_air + tracer(i,k,j,p_fire_smoke)=tracer(i,k,j,p_fire_smoke)+emis + end do + else + call wrf_error_fatal('Invalid fire smoke release option: check fire_smk_scheme namelist option') + end if + end if enddo enddo enddo @@ -75,6 +115,7 @@ SUBROUTINE fire_tendency( & its,ite, kts,kte, jts,jte, & grnhfx,grnqfx,canhfx,canqfx, & ! heat fluxes summed up to atm grid alfg,alfc,z1can, & ! coeffients, properties, geometry + fire_sfc_flx,fire_heat_peak,fire_tg_ub, & !options for heat release zs,z_at_w,dz8w,mu,c1h,c2h,rho, & rthfrten,rqvfrten) ! theta and Qv tendencies @@ -106,6 +147,9 @@ SUBROUTINE fire_tendency( & REAL, INTENT(in) :: alfg ! extinction depth surface fire heat (m) REAL, INTENT(in) :: alfc ! extinction depth crown fire heat (m) REAL, INTENT(in) :: z1can ! height of crown fire heat release (m) + INTEGER, INTENT(in) :: fire_sfc_flx !switch for the heat release scheme + REAL, INTENT(in) :: fire_heat_peak !peak heat release height for TG + REAL, INTENT(in) :: fire_tg_ub !upper bound for TG ! --- outgoing variables @@ -124,6 +168,8 @@ SUBROUTINE fire_tendency( & REAL :: fact_g, fact_c REAL :: alfg_i, alfc_i + REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: prop_heat !proportion of heat to be released fro TG dist. + REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: hfx,qfx !! character(len=128)::msg @@ -161,45 +207,72 @@ SUBROUTINE fire_tendency( & j_st = MAX(jts,jds+1) j_en = MIN(jte,jde-1) -! --- distribute fluxes +! --- check if TG is used, and create proportion + if (fire_sfc_flx .eq. 1) then !Truncated Gaussian scheme + call tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_heat_peak,fire_tg_ub,alfg,z_at_w,zs, & + prop_heat) + end if +! --- distribute fluxes DO j = j_st,j_en DO k = k_st,k_en DO i = i_st,i_en - - ! --- set z (in meters above ground) - - z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st - - ! --- heat flux - - fact_g = cp_i * EXP( - alfg_i * z_w ) - IF ( z_w < z1can ) THEN - fact_c = cp_i - ELSE - fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) ) - END IF - hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) - -!! write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j) -!!2 format('hfx:',3i4,6e11.3) -!! call message(msg) - - ! --- vapor flux - - fact_g = xlv_i * EXP( - alfg_i * z_w ) - IF (z_w < z1can) THEN - fact_c = xlv_i - ELSE - fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) ) - END IF - qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + if (fire_sfc_flx .eq. 0) then + ! --- set z (in meters above ground) + z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st + + ! --- heat flux + fact_g = cp_i * EXP( - alfg_i * z_w ) + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) + +!! write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j) +!!2 format('hfx:',3i4,6e11.3) +!! call message(msg) + + ! --- vapor flux + + fact_g = xlv_i * EXP( - alfg_i * z_w ) + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) -!! if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then -!! write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j) -!!1 format('tend:',3i6,2e11.3) -!! call message(msg) -! endif +!! if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then +!! write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j) +!!1 format('tend:',3i6,2e11.3) +!! call message(msg) +! endif + else if (fire_sfc_flx .eq. 1) then !Truncated Gaussian scheme + ! heat flux + fact_g = prop_heat(i,k,j) * cp_i + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * prop_heat(i,k,j) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canqfx(i,j) + + ! vapor flux + fact_g = prop_heat(i,k,j) * xlv_i + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * prop_heat(i,k,j) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + + else + call wrf_error_fatal('Invalid fire heat release option: check fire_sfc_flx namelist option') + end if END DO END DO @@ -230,6 +303,69 @@ SUBROUTINE fire_tendency( & END SUBROUTINE fire_tendency +SUBROUTINE tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_peak_hgt,fire_tg_ub,fire_ext_depth,z_at_w,zs, & + prop) + !!!! Truncated Gaussian Distribution Subroutine for Heat and Smoke Release + !!!! Developed by: Kasra Shamsaei (Univ. of Nevada, Reno) and Tim Juliano (NCAR/RAL) + !!!! Supervised by: Branko Kosovic (NCAR/RAL) + + IMPLICIT NONE + + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: i_st,i_en, j_st,j_en, k_st,k_en !loop indices + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w ! dz across w-lvl + REAL, INTENT(in) :: fire_peak_hgt !peak heat release height for Truncated Gaussian scheme + REAL, INTENT(in) :: fire_tg_ub !upper bound for the Truncated Gaussian scheme + REAL, INTENT(in) :: fire_ext_depth !extinction depth surface fire heat (m) + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + REAL, INTENT(out), DIMENSION( i_st:i_en,k_st:k_en,j_st:j_en ) :: prop !proportion of heat or smoke to be released + + ! --- local for Truncated Gaussian + INTEGER :: i,j,k + + REAL, PARAMETER :: acoef = 167./148., bcoef = 11./109., fire_tg_lb = 0. + REAL :: xia, xib + REAL :: phi_a, phi_b + REAL :: xi + REAL :: dz + REAL :: z_w + REAL :: prop_temp + + xia = (fire_tg_lb-fire_peak_hgt)/(0.5*fire_ext_depth) + xib = (fire_tg_ub-fire_peak_hgt)/(0.5*fire_ext_depth) + + phi_a = 0.5*(1.+tanh(acoef*xia+bcoef*(xia**3))) + phi_b = 0.5*(1.+tanh(acoef*xib+bcoef*(xib**3))) + + DO j = j_st,j_en + DO k = k_st,k_en + DO i = i_st,i_en + + xi=(z_w-fire_peak_hgt)/(0.5*fire_ext_depth) + + prop_temp = 0.5*(acoef+3.*bcoef*(xi**2))/(0.5*fire_ext_depth)*(1.-(tanh(acoef*xi+bcoef*(xi**3)))**2) + prop_temp = prop_temp / (phi_b-phi_a) + + !discretize the continuous function + if (k .eq. k_st) then + dz = 0.5 * dz8w(i,k,j) + else if (k .eq. k_en) then + dz = 0.5 * dz8w(i,k-1,j) + else + dz = 0.5 * (dz8w(i,k,j) + dz8w(i,k-1,j)) + end if + + prop(i,k,j) = prop_temp * dz + + END DO + END DO + END DO + +END SUBROUTINE tg_dist + ! !*** ! diff --git a/phys/module_fr_fire_driver.F b/phys/module_fr_fire_driver.F index 1e1898901f..acd6b35933 100644 --- a/phys/module_fr_fire_driver.F +++ b/phys/module_fr_fire_driver.F @@ -352,7 +352,8 @@ subroutine fire_driver_em ( grid , config_flags & ips,ipe,kps,kpe,jps,jpe, & rho,dz8w, & grid%burnt_area_dt,grid%fgip, & - grid%tracer,config_flags%fire_tracer_smoke) + grid%tracer,config_flags%fire_tracer_smoke, & + config_flags%fire_smk_scheme,config_flags%fire_smk_peak,config_flags%fire_smk_ext,config_flags%fire_tg_ub,grid%ht,z_at_w) endif ! DME enddo diff --git a/phys/module_fr_fire_driver_wrf.F b/phys/module_fr_fire_driver_wrf.F index e77b96f819..c12019d7b0 100644 --- a/phys/module_fr_fire_driver_wrf.F +++ b/phys/module_fr_fire_driver_wrf.F @@ -130,6 +130,7 @@ subroutine fire_driver_em_step (grid , config_flags & its,ite, kts,kte, jts,jte, & ! grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx, & ! fluxes on atm grid config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt, & + config_flags%fire_sfc_flx,config_flags%fire_heat_peak,config_flags%fire_tg_ub, & grid%ht,z_at_w,dz8w,grid%mut,grid%c1h,grid%c2h,rho, & grid%rthfrten,grid%rqvfrten) ! out diff --git a/phys/module_microphysics_driver.F b/phys/module_microphysics_driver.F index 7bfcaf901b..b2182998fe 100644 --- a/phys/module_microphysics_driver.F +++ b/phys/module_microphysics_driver.F @@ -104,6 +104,7 @@ SUBROUTINE microphysics_driver( & ,snownc, snowncv & ,hailnc, hailncv & ,graupelnc, graupelncv & + ,hail_maxk1, hail_max2d & #if ( WRF_CHEM == 1 ) ,rainprod, evapprod & ,qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp & @@ -166,8 +167,8 @@ SUBROUTINE microphysics_driver( & USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, THOMPSONGH, FAST_KHAIN_LYNN_SHPUND, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG, MADWRF_MP & - ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, MADWRF_MP & + ,FER_MP_HIRES_ADVECT & ,WSM7SCHEME, WDM7SCHEME & ,NUWRF4ICESCHEME & ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN, P3_1CATEGORY, P3_1CATEGORY_NC, P3_2CATEGORY, P3_1CAT_3MOM & @@ -241,8 +242,9 @@ SUBROUTINE microphysics_driver( & USE module_mp_cammgmp_driver, ONLY: CAMMGMP ! CAM5's microphysics driver # endif ! USE module_mp_milbrandt3mom +#if (WRFPLUS != 1) & !defined( VAR4D ) USE module_mp_nssl_2mom - +#endif USE module_mixactivate, only: prescribe_aerosol_mixactivate ! For checking model timestep is history time (for radar reflectivity) @@ -681,7 +683,8 @@ SUBROUTINE microphysics_driver( & ,GRAUPELNC & ,GRAUPELNCV & ,HAILNC & - ,HAILNCV + ,HAILNCV & + ,hail_maxk1, hail_max2d #if ( WRF_CHEM == 1) ! NUWRF JJS 20110525 vvvvv @@ -783,6 +786,10 @@ SUBROUTINE microphysics_driver( & REAL :: constants_irrigation,tloc,irr_start,phase INTEGER, OPTIONAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: irr_rand_field +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + !--------------------------------------------------------------------- ! check for microphysics type. We need a clean way to ! specify these things! @@ -799,7 +806,7 @@ SUBROUTINE microphysics_driver( & ENDIF ! set this to true to print out the global max/min for W on each time step. - IF ( .false. ) THEN + IF ( .true. ) THEN wmax = maxval( w(ips:ipe,kps:kpe,jps:jpe) ) wmin = minval( w(ips:ipe,kps:kpe,jps:jpe) ) #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) @@ -898,7 +905,7 @@ SUBROUTINE microphysics_driver( & IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN ! ERM: check whether to use built-in droplet nucleation or use qndrop from CHEM - IF ( mp_physics==NSSL_2MOMCCN .or. mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG ) THEN + IF ( mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1 ) THEN IF ( progn > 0 ) THEN IF ( .not. (chem_opt == 0 .or. chem_opt == 401) ) nssl_progn = .true. ELSE @@ -923,11 +930,11 @@ SUBROUTINE microphysics_driver( & its,ite, jts,jte, kts,kte, & F_QC=f_qc, F_QI=f_qi ) END IF - ELSEIF ( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. (mp_physics==NSSL_2MOMCCN .or. & - mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG)) THEN + ELSEIF ( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. & + (mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1)) THEN ! Do nothing here for the moment. Use activation of CCN within the NSSL_2MOM scheme instead, based on nssl_cccn namelist value. ELSEIF ( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT & - .AND. mp_physics/=NSSL_2MOM .AND. mp_physics/=NSSL_2MOMCCN .AND. mp_physics/=NSSL_2MOMG ) THEN + .AND. .not. (mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1) ) THEN call wrf_error_fatal( & "SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON or NSSL_2MOM.") END IF @@ -1926,136 +1933,20 @@ SUBROUTINE microphysics_driver( & ! Call wrf_error_fatal( 'arguments not present for calling milbrandt3mom') ! ENDIF - CASE (NSSL_1MOM) - CALL wrf_debug(100, 'microphysics_driver: calling nssl1mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. & - PRESENT (QR_CURR) .AND. & - PRESENT (QI_CURR) .AND. & - PRESENT (QS_CURR) .AND. & - PRESENT (QG_CURR) .AND. & - PRESENT (QH_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - QHL=qh_curr, & -! CCW=qnc_curr, & -! CRW=qnr_curr, & -! CCI=qni_curr, & -! CSW=qns_curr, & -! CHW=qng_curr, & -! CHL=qnh_curr, & - VHW=qvolg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & - diagflag = diagflag, & - ke_diag = ke_diag, & - IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & - IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & - ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_1mom') - ENDIF - - CASE (NSSL_1MOMLFO) - CALL wrf_debug(100, 'microphysics_driver: calling nssl1mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. & - PRESENT (QR_CURR) .AND. & - PRESENT (QI_CURR) .AND. & - PRESENT (QS_CURR) .AND. & - PRESENT (QG_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & - diagflag = diagflag, & - ke_diag = ke_diag, & - IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & - IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & - ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_1momlfo') - ENDIF CASE (NSSL_2MOM) +#if (WRFPLUS != 1) & !defined( VAR4D ) + ! For all 1,2,3-moment options CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & #if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & #endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & - PRESENT (QVOLH_CURR) .AND. F_QVOLH ) THEN + PRESENT ( W ) ) THEN CALL nssl_2mom_driver( & @@ -2075,8 +1966,12 @@ SUBROUTINE microphysics_driver( & CSW=qns_curr, & CHW=qng_curr, & CHL=qnh_curr, & - VHW=qvolg_curr, & - VHL=qvolh_curr, & + VHW=qvolg_curr, f_vhw=F_QVOLG, & + VHL=qvolh_curr, f_vhl=F_QVOLH, & + ZRW=qzr_curr, f_zrw = f_qzr, & + ZHW=qzg_curr, f_zhw = f_qzg, & + ZHL=qzh_curr, f_zhl = f_qzh, & + cn=qnn_curr, f_cn=f_qnn, & PII=pi_phy, & P=p, & W=w, & @@ -2111,6 +2006,9 @@ SUBROUTINE microphysics_driver( & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + hail_maxk1=hail_maxk1, & + hail_max2d=hail_max2d, & + nwp_diagnostics=config_flags%nwp_diagnostics, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -2119,165 +2017,7 @@ SUBROUTINE microphysics_driver( & ELSE Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') ENDIF - - CASE (NSSL_2MOMG) - CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & #endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - ! CCW=qnc_curr, & - CCW=qndrop_curr, & - CRW=qnr_curr, & - CCI=qni_curr, & - CSW=qns_curr, & - CHW=qng_curr, & - VHW=qvolg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & -#if ( WRF_CHEM == 1 ) - WETSCAV_ON = config_flags%wetscav_onoff == 1, & - EVAPPROD=evapprod,RAINPROD=rainprod, & -#endif - nssl_progn=nssl_progn, & - diagflag = diagflag, & - cu_used=cu_used, & - qrcuten=qrcuten, & ! hm - qscuten=qscuten, & ! hm - qicuten=qicuten, & ! hm - qccuten=qccuten, & ! hm - re_cloud=re_cloud, & - re_ice=re_ice, & - re_snow=re_snow, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & - IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & - ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2momg') - ENDIF - - CASE (NSSL_2MOMCCN) - CALL wrf_debug(100, 'microphysics_driver: calling nssl_2momccn') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNDROP_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & - PRESENT (QVOLH_CURR) .AND. F_QVOLH .AND. & - PRESENT( QNN_CURR ) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - QHL=qh_curr, & -! CCW=qnc_curr, & - CCW=qndrop_curr, & - CRW=qnr_curr, & - CCI=qni_curr, & - CSW=qns_curr, & - CHW=qng_curr, & - CHL=qnh_curr, & - VHW=qvolg_curr, & - VHL=qvolh_curr, & - cn=qnn_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & -#if ( WRF_CHEM == 1 ) - WETSCAV_ON = config_flags%wetscav_onoff == 1, & - EVAPPROD=evapprod,RAINPROD=rainprod,& -#endif - nssl_progn=nssl_progn, & - diagflag = diagflag, & - ke_diag = ke_diag, & - cu_used=cu_used, & - qrcuten=qrcuten, & ! hm - qscuten=qscuten, & ! hm - qicuten=qicuten, & ! hm - qccuten=qccuten, & ! hm - re_cloud=re_cloud, & - re_ice=re_ice, & - re_snow=re_snow, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & - IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & - ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2momccn') - ENDIF ! CASE (GSFCGCESCHEME) CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' ) @@ -2593,9 +2333,14 @@ SUBROUTINE microphysics_driver( & ,has_reqc=has_reqc & ! for radiation + ,has_reqi=has_reqi & ,has_reqs=has_reqs & + ,re_qc_bg=re_qc_bg,re_qi_bg=re_qi_bg & + ,re_qs_bg=re_qs_bg & + ,re_qc_max=re_qc_max,re_qi_max=re_qi_max & + ,re_qs_max=re_qs_max & ,re_cloud=re_cloud & ,re_ice=re_ice & ,re_snow=re_snow & ! for radiation - + ,errmsg=errmsg, errflg=errflg & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & diff --git a/phys/module_mp_nssl_2mom.F b/phys/module_mp_nssl_2mom.F index 10d5f1cd51..d89baf3571 100644 --- a/phys/module_mp_nssl_2mom.F +++ b/phys/module_mp_nssl_2mom.F @@ -1,8 +1,6 @@ !WRF:MODEL_LAYER:PHYSICS - -! prepocessed on "Sep 7 2021" at "19:37:43" - +! prepocessed on "Aug 14 2023" at "16:15:23" @@ -25,35 +23,33 @@ ! ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! -! This module provides a 2-moment bulk microphysics scheme originally -! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in -! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation -! follows Mansell (2010, JAS), using parameter infall = 4. -! -! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) -! -! Average graupel particle density is predicted, which affects fall speed as well. -! Hail density prediction is by default disabled in this version, but may be enabled -! at some point if there is interest. -! -! Maintainer: Ted Mansell, National Severe Storms Laboratory -! -! Microphysics References: -! -! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small -! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. -! -! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and -! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, -! doi:10.1175/JAS-D-12-0264.1. -! -! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. -! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. -! -! Sedimentation reference: -! -! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. -! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel and hail particle densities are predicted, which affects fall speed as well. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. ! ! Possible parameters to adjust: ! @@ -66,18 +62,26 @@ ! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The ! implementation of an explicit charging and discharge lightning scheme ! within the WRF-ARW model: Benchmark simulations of a continental squall line, a -! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 ! -! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated ! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 ! ! Note: Some parameters below apply to unreleased features. ! ! !--------------------------------------------------------------------- +! Apr. 2023 (WRF-4.6) +! - Update to 3-moment for rain, graupel, and hail +! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) +! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds. +! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom, +! using wet growth diameter to convert large graupel +!--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: -! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) ! Other: ! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) ! Reordered collection coefficients (dab1lh) to be consistent (no effect) @@ -169,7 +173,6 @@ MODULE module_mp_nssl_2mom - IMPLICIT NONE public nssl_2mom_driver @@ -212,14 +215,13 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband - + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params - real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) @@ -232,8 +234,10 @@ MODULE module_mp_nssl_2mom real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) - real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value - real , public :: qccn ! ccn "mixing ratio" + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value + real , public :: qccn, qccnuf ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual @@ -242,10 +246,17 @@ MODULE module_mp_nssl_2mom ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state #else - logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state + logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN + real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018) + real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.) + logical :: decayufccn = .false. + integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn) ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) @@ -254,6 +265,7 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. @@ -264,14 +276,20 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates) real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.0 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.0 ! factor to adjust snow fall speed real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) - integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. - integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + real :: axh = 75.7149, bxh = 0.5 + real :: axf = 75.7149, bxf = 0.5 + real :: axhl = 206.984, bxhl = 0.6384 real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) @@ -305,7 +323,7 @@ MODULE module_mp_nssl_2mom integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds - integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) real , private :: rimc3 = 170.0 ! minimum rime density real :: rimc4 = 900.0 ! maximum rime density @@ -320,7 +338,7 @@ MODULE module_mp_nssl_2mom ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) - integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) ! =2 renucleation following Twomey/Cohard&Pinty ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base @@ -342,6 +360,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets) integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version @@ -352,7 +371,9 @@ MODULE module_mp_nssl_2mom integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) @@ -379,9 +400,9 @@ MODULE module_mp_nssl_2mom integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C - real , private :: ehw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency + real , private :: ehw0 = 0.9 ! 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency - real , private :: ehlw0 = 0.75 ! constant or max assumed hail-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! 0.75 ! constant or max assumed hail-droplet collection efficiency real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency @@ -408,15 +429,19 @@ MODULE module_mp_nssl_2mom ! set eii1 = 0 to get a constant value of eii0 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl + real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi + real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 - real , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI + ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 - real , private :: esstem1 = -25. ! lower temperature where snow aggregation turns on - real , private :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off @@ -447,11 +472,13 @@ MODULE module_mp_nssl_2mom ! 0 = no condensation on rain; 1 = bulk condensation on rain integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail @@ -475,6 +502,7 @@ MODULE module_mp_nssl_2mom real, private :: qhdpvdn = -1. real, private :: qhacidn = -1. + integer, private :: iraintypes = 0 logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density @@ -506,17 +534,23 @@ MODULE module_mp_nssl_2mom real, parameter :: alpharmax = 8. ! limited for rwvent calculation - integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold + ! 3 = Conversion using wet growth diameter real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) - real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) - real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL + real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. @@ -533,6 +567,8 @@ MODULE module_mp_nssl_2mom ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup + integer :: iraintailbreak = 0 ! 1 = on + real :: draintail = 8.e-3 ! starting size for rain breakup integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) @@ -540,7 +576,7 @@ MODULE module_mp_nssl_2mom ! = 2 DTD mass-weighted version based on MY code ! = 3 Milbrandt version (from Cohard and Pinty code integer :: dmropt = 0 ! extra option for crcnw - integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: dmhlopt = 0 ! options for graupel -> hail conversion integer :: irescalerainopt = 3 ! 0 = default option ! 1 = qx(mgs,lc) > qxmin(lc) ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 @@ -557,6 +593,7 @@ MODULE module_mp_nssl_2mom integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted + logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters ! 1 = original Zrnic et al. (Mansell et al. 2010) @@ -589,9 +626,12 @@ MODULE module_mp_nssl_2mom integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0 + integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0 real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) @@ -602,6 +642,7 @@ MODULE module_mp_nssl_2mom ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) ! 4 = add droplets with minimum radius of 20 microns real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) @@ -732,6 +773,7 @@ MODULE module_mp_nssl_2mom real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 real bb (lc:lqmx) + ! put ipelec here for now.... integer :: ipelec = 0 integer :: isaund = 0 @@ -757,8 +799,8 @@ MODULE module_mp_nssl_2mom double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 - integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 + integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25 ! real, parameter :: maxratiolu = 25. real, parameter :: maxratiolu = 100. ! 25. real, parameter :: maxalphalu = 15. @@ -775,6 +817,10 @@ MODULE module_mp_nssl_2mom ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) ! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! for 3-moment collection coefficients + real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -810,7 +856,6 @@ MODULE module_mp_nssl_2mom ! ! constants ! - real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) real, parameter :: aradcw = -0.27544 ! @@ -827,12 +872,14 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv + + real, parameter :: gr = 9.8 + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = 9.8 - ! ! max and min mean volumes ! @@ -853,7 +900,7 @@ MODULE module_mp_nssl_2mom ! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius - real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 @@ -895,25 +942,28 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = 273.15, tfrh = 233.15 + real, parameter :: tfrh = 233.15 + real, parameter :: tfr = 273.15 real, parameter :: cp = 1004.0, rd = 287.04 - real, parameter :: cpi = 1./cp - real, parameter :: cap = rd/cp, poo = 1.0e+05 - real, parameter :: rw = 461.5 ! gas const. for water vapor + real, parameter :: cpl = 4190.0 + real, parameter :: cpigb = 2106.0 + real, parameter :: cpi = 1./cp + real, parameter :: cap = rd/cp + real, parameter :: tfrcbw = tfr - cbw + real, parameter :: tfrcbi = tfr - cbi + real, parameter :: rovcp = rd/cp + real :: rdorv = 0.622 + real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity - real, parameter :: tfrcbw = tfr - cbw - real, parameter :: tfrcbi = tfr - cbi ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd - real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air - REAL, PRIVATE, parameter :: cvv = 1408.5 - REAL, PRIVATE, parameter :: cpl = 4190.0 - REAL, PRIVATE, parameter :: cpigb = 2106.0 + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -942,10 +992,12 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. + integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + logical, private :: nuaccoinp = .false. ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. -! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& @@ -955,7 +1007,7 @@ MODULE module_mp_nssl_2mom idbzci, & vtmaxsed, & itfall,iscfall, & - infall, & + infall,irfall,isfall, & rssflg, & sssflg, & hssflg, & @@ -966,12 +1018,15 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + decayufccn, ufccntimeconst, & + switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, & + icenucopt, in_freeze_rain_first, & naer, & icfn, & ibfc, iacr, icracr, & + icracrthresh, & cwfrz2snowfrac, cwfrz2snowratio, & ibfr, & ibiggopt, & @@ -987,7 +1042,7 @@ MODULE module_mp_nssl_2mom eri_cimin, & eii0hl, eii1hl, & ehs0, ehs1, & - ess0, ess1, & + ess0, ess1, iessopt, & esstem1,esstem2, & ircnw, qminrncw,& ! single-moment only iglcnvi, & @@ -1013,6 +1068,7 @@ MODULE module_mp_nssl_2mom hailfallfac, & icefallopt, & icdx,icdxhl, & + axh,bxh,axf,bxf,axhl,bxhl, & cdhmin, cdhmax, & cdhdnmin, cdhdnmax, & cdhlmin, cdhlmax, & @@ -1047,7 +1103,7 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1080,7 +1136,6 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & - charging_border, & do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1106,10 +1161,10 @@ END FUNCTION fqis -! ##################################################################### -! ##################################################################### +! ##################################################################### +! ##################################################################### SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & & nssl_graupelfallfac, & @@ -1119,7 +1174,15 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdx, & & nssl_icdxhl, & & nssl_icefallfac, & - & nssl_snowfallfac & + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_ufccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar, & + & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & + & infileunit, & + & myrank, mpiroot & ) implicit none @@ -1130,21 +1193,35 @@ SUBROUTINE nssl_2mom_init( & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icefallfac, & - & nssl_snowfallfac + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar integer, intent(in), optional :: & & nssl_icdx, & - & nssl_icdxhl + & nssl_icdxhl, myrank, mpiroot, & + & nssl_ufccn + logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + integer, intent(inout), optional :: ccn_is_ccna - integer, intent(in) :: ims,ime, jms,jme, kms,kme - real, intent(in), dimension(20) :: nssl_params + integer, intent(in),optional :: infileunit + integer, intent(in), optional :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20), optional :: nssl_params - integer, intent(in) :: ipctmp,mixphase,ihvol + + + integer, intent(in) :: ipctmp,mixphase + integer, optional, intent(in) :: ihvol logical, optional, intent(in) :: idoniconlytmp + integer :: igvol_local = 1 logical :: wrote_namelist = .false. logical :: wrf_dm_on_monitor + integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 + integer :: ccn_on = -1 double precision :: arg real :: temq @@ -1152,20 +1229,57 @@ SUBROUTINE nssl_2mom_init( & integer :: i,il,j,l integer :: ltmp integer :: isub - real :: bxh,bxhl + real :: bxh1,bxhl1 real :: alp,ratio double precision :: x,y,y2,y7 logical :: turn_on_ccna, turn_on_cina + integer :: iufccn = 0 integer :: istat + + real :: alpjj, alpii, xnuii, xnujj + integer :: ii, jj turn_on_ccna = .false. turn_on_cina = .false. + +! IF ( present( igvol ) ) THEN +! igvol_local = igvol +! ENDIF + + IF ( present( nssl_hail_on ) ) THEN + IF ( nssl_hail_on ) THEN + hail_on = 1 + ELSE + hail_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_density_on ) ) THEN + IF ( nssl_density_on ) THEN + density_on = 1 + ELSE + density_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_icecrystals_on ) ) THEN + IF ( nssl_icecrystals_on ) THEN + icecrystals_on = 1 + ELSE + icecrystals_on = 0 + ! renucfrac = 1.0 ! why was this set to 1? + ffrzs = 1.0 + ENDIF + ENDIF + + ! ! set some global values from namelist input ! + IF ( present( nssl_params ) ) THEN ccn = Abs( nssl_params(1) ) alphah = nssl_params(2) alphahl = nssl_params(3) @@ -1176,36 +1290,77 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + ccnuf = Abs( nssl_params(14) ) + IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn + + ENDIF ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) + + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac - IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 - IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_ehw0) ) THEN + IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0 + ENDIF + IF ( present(nssl_ehlw0) ) THEN + IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0 + ENDIF IF ( present(nssl_icdx) ) icdx = nssl_icdx IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + IF ( present(nssl_cccn) ) THEN + IF (nssl_cccn > 1 ) ccn = nssl_cccn + ENDIF + IF ( present(nssl_alphah) ) THEN + IF ( nssl_alphah > -1. ) alphah = nssl_alphah + ENDIF + IF ( present(nssl_alphahl) ) THEN + IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl + ENDIF + IF ( present(nssl_alphar) ) THEN + IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar + ENDIF - IF ( Nint(nssl_params(13)) == 1 ) THEN - ! hack to switch CCN field to CCNA (activated ccn) -! invertccn = .true. - turn_on_ccna = .true. - irenuc = 7 + ipconc = ipctmp + + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ENDIF + + IF ( ihlcnh <= 0 ) THEN + IF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN + ihlcnh = 3 ENDIF + ENDIF - IF ( .false. ) THEN ! set to true to enable internal namelist read + + IF ( .true. ) THEN ! set to true to enable internal namelist read open(15,file='namelist.input',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) IF ( istat /= 0 ) THEN - write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' +#ifdef WRF_ELEC + IF ( wrf_dm_on_monitor() ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF +#else + ! write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' +#endif ENDIF IF ( wrf_dm_on_monitor() .and. .not. wrote_namelist ) THEN open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted') @@ -1217,8 +1372,42 @@ SUBROUTINE nssl_2mom_init( & + IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn + irenuc = 7 + IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay + IF ( i_uf_or_ccn > 0 ) THEN + ufbackground = 0.0 + ccntimeconst = ufccntimeconst + ENDIF + ENDIF + + IF ( present( nssl_ccn_on ) ) THEN + IF ( nssl_ccn_on ) THEN + ccn_on = 1 + ELSE + ccn_on = 0 + irenuc = 2 + ENDIF + ENDIF + IF ( irenuc >= 5 ) THEN turn_on_ccna = .true. + IF ( present( nssl_ccn_on ) ) THEN + IF ( .not. nssl_ccn_on ) THEN + write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + STOP + ENDIF + ENDIF + ENDIF + + IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN + IF ( ccn_is_ccna > 0 ) THEN + turn_on_ccna = .true. + ELSE + IF ( irenuc >= 5 ) THEN + ccn_is_ccna = 1 + ENDIF + ENDIF ENDIF cwccn = ccn @@ -1232,24 +1421,41 @@ SUBROUTINE nssl_2mom_init( & lh = lh + 1 lhl = lhl + 1 ENDIF - IF ( ihvol <= -1 .or. ihvol == 2 ) THEN - IF ( ihvol == -1 .or. ihvol == -2 ) THEN - lhab = lhab - 1 ! turns off hail - lhl = 0 - ! past me thought it would be a good idea to change graupel factors when hail is off.... - ! ehw0 = 0.75 - ! iehw = 2 - ! dfrz = Max( dfrz, 0.5e-3 ) - ENDIF - IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off - ! a value of -3 means to turn off ice crystals but turn on hail - renucfrac = 1.0 - ffrzs = 1.0 - ! idoci = 0 ! try this later + IF ( hail_on == -1 ) THEN ! hail_on is not set + hail_on = 1 + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + hail_on = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off + ! a value of 2? means to turn off ice crystals but turn on hail + ! renucfrac = 1.0 ! why? + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + ELSE ! hail_on is set + IF ( hail_on == 0 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ELSE + ! assume default that hail is on ENDIF ENDIF + + IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it + density_on = 1 + ENDIF + -! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl +! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1276,29 +1482,42 @@ SUBROUTINE nssl_2mom_init( & bx(lr) = 0.85 ax(lr) = 1647.81 fx(lr) = 135.477 + IF ( icdx == 6 ) THEN bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. ax(lh) = 157.71 - ELSEIF ( icdx > 0 ) THEN +! ELSEIF ( icdx == 1 ) THEN +! bx(lh) = bxh +! ax(lh) = axh + ELSEIF ( icdx > 1 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 - ELSE - bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ELSEIF ( icdx == 0 ) THEN + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel ax(lh) = 19.3 + ELSE ! icdx < 0 +! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops +! bx(lh) = 0.6384 + bx(lh) = bxh + ax(lh) = axh ENDIF + ! bx(lh) = 0.6 IF ( lhl .gt. 1 ) THEN IF ( icdxhl == 6 ) THEN bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. ax(lhl) = 179.36 + ELSEIF (icdxhl == 0 ) THEN + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 ELSEIF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 + bx(lhl) = 0.5 + ax(lhl) = 75.7149 ELSE - ax(lhl) = 206.984 ! Ferrier 1994 - bx(lhl) = 0.6384 + bx(lhl) = bxhl + ax(lhl) = axhl ENDIF ENDIF @@ -1314,8 +1533,8 @@ SUBROUTINE nssl_2mom_init( & ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) - bxh = bx(lh) - bxhl = bx(Max(lh,lhl)) + bxh1 = bx(lh) + bxhl1 = bx(Max(lh,lhl)) ! DO j = 0,nqiacralpha DO j = ialpstart,nqiacralpha @@ -1331,9 +1550,9 @@ SUBROUTINE nssl_2mom_init( & ! graupel (.,.,.,1) gamxinflu(i,j,1,1) = x/y gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y - gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y - gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y @@ -1342,9 +1561,9 @@ SUBROUTINE nssl_2mom_init( & ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) - gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) - gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) @@ -1352,16 +1571,16 @@ SUBROUTINE nssl_2mom_init( & ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y ! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y -! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y ELSE ! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y -! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y -! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y - gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y ENDIF gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) @@ -1395,9 +1614,8 @@ SUBROUTINE nssl_2mom_init( & qiacrratio(0,:) = 1.0 - isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 - lccn = 0 + lccnuf = 0 lccna = 0 lnc = 0 lnr = 0 @@ -1419,34 +1637,41 @@ SUBROUTINE nssl_2mom_init( & ! lccn = 9 - ipconc = ipctmp IF ( ipconc == 0 ) THEN - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme lvh = 9 ltmp = 9 denscale(lvh) = 1 - ELSE ! no hail + ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 ENDIF ELSEIF ( ipconc == 5 ) THEN - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + ENDIF + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1464,24 +1689,31 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - STOP - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh IF ( lhl > 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on == 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off + ENDIF ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1501,19 +1733,14 @@ SUBROUTINE nssl_2mom_init( & lzh = ltmp ltmp = ltmp + 1 lzr = ltmp - ltmp = ltmp + 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp ENDIF + ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF ! ltmp = lvh ! denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN - lvhl = ltmp+1 - ltmp = lvhl - denscale(lvhl) = 1 - ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp @@ -1531,7 +1758,8 @@ SUBROUTINE nssl_2mom_init( & - + ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl + ! write(0,*) 'wrf_init: ipconc = ',ipconc ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 @@ -1763,9 +1991,16 @@ SUBROUTINE nssl_2mom_init( & IF ( lhl .gt. 1 ) ido(lhl) = idohl IF ( irfall .lt. 0 ) irfall = infall + IF ( isfall .lt. 0 ) isfall = infall IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + qccnuf = ccnuf/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF ! xvcmx = (4./3.)*pi*xcradmx**3 ! set max rain diameter @@ -1914,6 +2149,33 @@ SUBROUTINE nssl_2mom_init( & ENDDO ENDDO + dab0lu(:,:,:,:) = 0.0 + dab1lu(:,:,:,:) = 0.0 + + IF ( ipconc >= 6 ) THEN + DO il = lc,lhab ! collector + DO j = lc,lhab ! collected + IF ( il .ne. j ) THEN + + DO jj = ialpstart,nqiacralpha + alpjj = float(jj)*dqiacralpha + xnujj = (alpjj - 2.)/3. + DO ii = ialpstart,nqiacralpha + alpii = float(ii)*dqiacralpha + xnuii = (alpii - 2.)/3. + + dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0) + dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1) + + ENDDO + ENDDO +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + ENDIF + gf4br = gamma_sp(4.0+br) gf4ds = gamma_sp(4.0+ds) gf4p5 = gamma_sp(4.0+0.5) @@ -1960,24 +2222,31 @@ END SUBROUTINE nssl_2mom_init ! ##################################################################### SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & - zrw, zhw, zhl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & + cnuf, f_cnuf, & + zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & + is_theta_or_temp, & + ntmul, ntcnt, lastloop, & RAINNC,RAINNCV, & dx, dy, & axtra, & SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + hail_maxk1, hail_max2d, nwp_diagnostics, & tkediss, & - re_cloud, re_ice, re_snow, & - has_reqc, has_reqi, has_reqs, & + re_cloud, re_ice, re_snow, re_rain, & + re_graup, re_hail, & + has_reqc, has_reqi, has_reqs, has_reqr, & + has_reqg, has_reqh, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elec,scion,sciona, & + induc,elecz,scion,sciona, & noninduc,noninducp,noninducn, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & @@ -2004,6 +2273,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + implicit none @@ -2021,7 +2292,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + integer, optional, intent(in) :: is_theta_or_temp + logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2032,8 +2305,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez - real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii @@ -2054,29 +2327,44 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra ! WRF variables - real, dimension(ims:ime, jms:jme), intent(inout):: & + real, dimension(ims:ime, jms:jme) :: & RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d + integer, optional, intent(in) :: nwp_diagnostics +! for cm1, set nproctot=44 (or as needed) to get domain total rates + integer, parameter :: nproc = 1 + double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & + re_rain, re_graup, re_hail REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, intent(in), optional :: ntmul, ntcnt + logical, optional, intent(in) :: lastloop + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf + logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl integer, optional, intent(in) :: ipelectmp, ke_diag + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag_cnuf = .false. + logical :: flag_ccn = .false. + logical :: flag_qi = .true. + logical :: has_reqr_local = .false., has_reqg_local = .false., has_reqh_local = .false. logical :: flag + logical :: nwp_diagflag = .false. real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2101,11 +2389,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1 + real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 - integer :: nx,ny,nz + integer :: nx,ny,nz,ngs integer ix,jy,kz,i,j,k,il,n integer :: infdo real :: ssival, ssifac, t8s, t9s, qvapor @@ -2116,6 +2407,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: dbzmx,refl integer :: vzflag0 = 0 logical :: makediag + real :: dx1,dy1 real, parameter :: cnin20 = 1.0e3 real, parameter :: cnin10 = 5.0e1 real, parameter :: cnin1a = 4.5 @@ -2129,7 +2421,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: grmass1,grmass2 double precision :: hlmass1,hlmass2 double precision :: wvol5,wvol10 - real :: tmp,dv,dv1 + real :: tmp,dv,dv1,tmpchg real :: rdt double precision :: dt1,dt2 @@ -2144,15 +2436,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) - -#ifdef MPI - -#if defined(MPI) - integer, parameter :: ntot = 50 - double precision mpitotindp(ntot), mpitotoutdp(ntot) - INTEGER :: mpi_error_code = 1 -#endif -#endif + + logical, parameter :: debugdriver = .false. + + integer :: loopcnt, loopmax, outerloopcnt + logical :: lastlooptmp ! ------------------------------------------------------------------- @@ -2160,18 +2448,58 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rdt = 1.0/dtp -! write(0,*) 'N2M: entering routine' + IF ( debugdriver ) write(0,*) 'N2M: entering routine' flag_qndrop = .false. flag_qnifa = .false. flag_qnwfa = .false. + flag_cnuf = .false. + flag_ccn = .false. + nwp_diagflag = .false. IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf + IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) + IF ( present ( f_cn ) .and. present( cn ) ) THEN + flag_ccn = f_cn + ELSEIF ( present( cn ) ) THEN + flag_ccn = .true. + ENDIF + + IF ( present( f_qi ) ) THEN + flag_qi = f_qi + ELSE + IF ( ffrzs < 1.0 ) THEN + flag_qi = .true. + ELSE + flag_qi = .false. + ENDIF + ENDIF + IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + + IF ( PRESENT ( has_reqr ) ) has_reqr_local = has_reqr > 0 + IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 + IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0 - ! --- + loopmax = 1 + outerloopcnt = 1 + lastlooptmp = .true. + IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN + loopmax = ntmul + outerloopcnt = ntcnt + lastlooptmp = lastloop + ENDIF + + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + ENDIF + ENDIF IF ( present( f_cna ) ) THEN f_cnatmp = f_cna @@ -2202,25 +2530,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDDO ! ENDIF + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN makediag = diagflag .or. itimestep == 1 ENDIF -! write(0,*) 'N2M: makediag = ',makediag + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 + ngs = 64 - IF ( .not. present( cn ) ) THEN + IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF + ! set up CCN array and some other static local values - IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN + IF ( itimestep == 1 .and. .not. invertccn .and. flag_ccn ) THEN ! this is not needed for WRF 3.8 and later because it is done in physics_init, ! but kept for backwards compatibility with earlier versions IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN @@ -2242,9 +2580,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ENDIF + + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN +! write(0,*) 'set cnuf1' + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF - IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN + IF ( itimestep == 1 .and. invertccn .and. flag_ccn ) THEN ! this is not needed for WRF 3.8 and later because it is done in physics_init, ! but kept for backwards compatibility with earlier versions DO jy = jts,jte @@ -2256,7 +2606,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF - IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to + IF ( invertccn .and. flag_ccn ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to ! worry about initial and boundary conditions - they are zero DO jy = jts,jte DO kz = kts,kte @@ -2265,7 +2615,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ENDDO + + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN +! write(0,*) 'set cnuf (invertccn)' + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) + ENDDO + ENDDO + ENDDO ENDIF + + ENDIF + ! ENDIF ! itimestep == 1 @@ -2316,32 +2679,36 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw -! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 + DO jy = jts,jye - xfall(:,:,:) = 0.0 - ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn IF ( present( pcc2 ) .and. makediag ) THEN axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF + IF ( nwp_diagflag ) THEN + alpha2d(its:ite,1,kts:kte,1) = alphar + alpha2d(its:ite,1,kts:kte,2) = alphah + alpha2d(its:ite,1,kts:kte,3) = alphahl + ENDIF + + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,lt) = th(ix,kz,jy) - - an(ix,1,kz,lv) = qv(ix,kz,jy) an(ix,1,kz,lc) = qc(ix,kz,jy) an(ix,1,kz,lr) = qr(ix,kz,jy) - IF ( present( qi ) ) THEN + IF ( flag_qi ) THEN an(ix,1,kz,li) = qi(ix,kz,jy) ELSE an(ix,1,kz,li) = 0.0 @@ -2352,13 +2719,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN ! - ELSEIF ( present( cn ) ) THEN + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) ELSE an(ix,1,kz,lccn) = cn(ix,kz,jy) ENDIF + IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn + an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2369,6 +2739,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ELSE ! UF were added to lccn + an(ix,1,kz,lccnuf) = 0.0 + ENDIF + ENDIF + IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN an(ix,1,kz,lccna) = cna(ix,kz,jy) @@ -2399,12 +2777,42 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale + IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale + IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale + ENDIF + ENDDO + ENDDO + + DO kz = kts,kte + DO ix = its,ite t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + ENDDO + ENDDO + + DO ix = its,ite + RAINNCV(ix,jy) = 0.0 + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0 + IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0 + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0 + ENDDO + + DO loopcnt = 1,loopmax + + DO kz = kts,kte + DO ix = its,ite + + t1(ix,1,kz) = 0.0 t2(ix,1,kz) = 0.0 t3(ix,1,kz) = 0.0 @@ -2414,14 +2822,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 - t00(ix,1,kz) = 380.0/p(ix,kz,jy) - t77(ix,1,kz) = pii(ix,kz,jy) - dbz2d(ix,1,kz) = 0.0 - vzf2d(ix,1,kz) = 0.0 - dn1(ix,1,kz) = dn(ix,kz,jy) pn(ix,1,kz) = p(ix,kz,jy) wn(ix,1,kz) = w(ix,kz,jy) + dn1(ix,1,kz) = dn(ix,kz,jy) ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) @@ -2439,6 +2843,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + if ( ssival .gt. 1.0 ) then ! IF ( icenucopt == 1 ) THEN @@ -2491,19 +2896,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 - IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 ! naer needs units of cm**-3, so mult by 1.e-6 - ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - t7(ix,jy,kz) = Min(dp1, 1.0d30) + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + tmp = 1.e-6*naer + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + t7(ix,1,kz) = Min(dp1, 1.0d30) ELSE - t7(ix,jy,kz) = 0.0 + ! t7(ix,1,kz) = 0.0 ENDIF ENDIF ! icenucopt @@ -2516,48 +2922,48 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz - has_wetscav = .false. - IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( wetscav_on ) ) THEN - has_wetscav = wetscav_on - IF ( has_wetscav ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 - ENDIF - ENDIF - ENDIF + IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF ENDDO ! il + ENDIF + ! sedimentation xfall(:,:,:) = 0.0 - IF ( .true. ) THEN + +! IF ( .true. ) THEN ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF ! #endif IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & - present( qicuten ) .or. present( qccuten ) ) ) THEN + present( qicuten ) .or. present( qccuten ) ) ) THEN !{ - IF ( cu_used == 1 ) THEN + IF ( cu_used == 1 ) THEN !{ DO kz = kts,kte DO ix = its,ite @@ -2571,10 +2977,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) - - ENDIF - - ENDIF + DO kz = kts,kte + DO ix = its,ite + + + IF ( ipconc >= 6 ) THEN +! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) + ENDIF + + ENDDO + ENDDO + + ENDIF !} + + ENDIF !} + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & @@ -2584,14 +3002,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! copy xfall to appropriate places... -! write(0,*) 'N2M: end sediment, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy DO ix = its,ite IF ( lhl > 1 ) THEN - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only @@ -2606,11 +3026,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF ENDIF - IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) - IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) - RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN + SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + ENDIF IF ( lhl > 1 ) THEN !#ifdef CM1 ! IF ( .true. ) THEN @@ -2618,13 +3046,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( HAILNC ) ) THEN !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) - HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) - ELSEIF ( present( GRPLNCV ) ) THEN - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF - IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) - IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN + GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + ENDIF + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN IF ( present( HAILNC ) ) THEN SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ELSE @@ -2633,12 +3063,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDDO - ENDIF ! .false. +! ENDIF ! .false. IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics -! write(0,*) 'N2M: gs, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy ! IF ( isedonly /= 2 ) THEN @@ -2655,8 +3085,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & - & ,has_wetscav, rainprod2d, evapprod2d & + & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & & ,elec2,its,ids,ide,jds,jde & & ) @@ -2674,28 +3105,32 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & - & ,pn,wn & + & ,pn,wn & + & ,ngs & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) + ENDIF + + + ENDDO ! loopcnt=1,loopmax IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite ! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. ! Search for 'axtra' to find example code below ! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) - ENDDO ENDDO ENDIF ! compute diagnostic S-band reflectivity if needed - IF ( present( dbz ) .and. makediag ) THEN + IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN @@ -2733,7 +3168,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & - present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & + lastlooptmp) THEN IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN DO kz = kts,kte DO ix = its,ite @@ -2743,14 +3179,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t1(ix,1,kz) = 2.51E-6 t2(ix,1,kz) = 10.01E-6 t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 ENDDO ENDDO + call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1,t2,t3 & - & ,an,dn1 ) + & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 & + & ,f_t4=has_reqr_local,f_t5=has_reqg_local, f_t6=has_reqh_local & + & ,an=an,dn=dn1 ) DO kz = kts,kte DO ix = its,ite @@ -2761,19 +3200,63 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqg) .and. present( re_graup ) ) THEN + IF ( has_reqg /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqh) .and. present( re_hail ) ) THEN + IF ( has_reqh /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF ENDIF ENDIF + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN + DO ix = its,ite + hailmax1d(ix,1) = hail_max2d(ix,jy) + hailmaxk1(ix,1) = hail_maxk1(ix,jy) + ENDDO + + call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, & + hailmax1d,hailmaxk1,1 ) + DO ix = its,ite + hail_max2d(ix,jy) = hailmax1d(ix,1) + hail_maxk1(ix,jy) = hailmaxk1(ix,1) + ENDDO +! ENDIF + ENDIF ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF @@ -2790,15 +3273,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qv(ix,kz,jy) = an(ix,1,kz,lv) qc(ix,kz,jy) = an(ix,1,kz,lc) qr(ix,kz,jy) = an(ix,1,kz,lr) - IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li) qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here - ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN - IF ( lccna > 1 .and. .not. present( cna ) ) THEN + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE cn(ix,kz,jy) = an(ix,1,kz,lccn) @@ -2816,6 +3299,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ENDIF + IF ( decayufccn ) THEN + IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN + an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - & + ufbackground)*(1.0 - exp(-dtp/ufccntimeconst)) + ENDIF + ENDIF + cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf) + ENDIF + + + IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2826,6 +3324,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv + IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv + IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv + ENDIF @@ -2834,6 +3337,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw #if ( WRF_CHEM == 1 ) IF ( has_wetscav ) THEN + IF ( loopmax > 1 ) THEN + ! wrferror not supported + ENDIF IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF @@ -2841,10 +3347,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO - + + ENDDO ! jy - IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated + + + + IF ( invertccn .and. flag_ccn ) THEN ! hack to convert unactivated ccn back to activated DO jy = jts,jte DO kz = kts,kte DO ix = its,ite @@ -2854,6 +3364,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) + ENDDO + ENDDO + ENDDO + ENDIF + + @@ -3042,7 +3563,6 @@ END function GAMXINFDP ! ##################################################################### -! #ifdef Z3MOM real function gaminterp(ratio, alp, luindex, ilh) implicit none @@ -3086,7 +3606,6 @@ real function gaminterp(ratio, alp, luindex, ilh) ! ENDIF END FUNCTION gaminterp -! #endif /* Z3MOM */ ! ##################################################################### !**************************** GAML02 *********************** @@ -3136,7 +3655,7 @@ END FUNCTION GAML02 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) ! ********************************************************** - real FUNCTION GAML02d300(x) + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x @@ -3429,7 +3948,7 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp - STOP + STOP ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -3468,7 +3987,8 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) RETURN END Function delabk - + + ! ##################################################################### ! @@ -3488,7 +4008,238 @@ end subroutine cld_cpu ! !-------------------------------------------------------------------------- ! - subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & +! ####################################################################### +! HAILMAXD - calculated maximum expected hail size +! ####################################################################### + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & + & hailmax1d,hailmaxk1,jslab ) +! +! Calculate maximum hail size from the tail of of the distribution. The value +! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf). +! This uses the lookup tables for incomplete gamma functions and simply search for +! the expected value (and linearly interpolate) on D. +! +! Written by ERM 7/2023 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density +! integer :: its,ite ! x-range to calculate + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters + real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + double precision :: tmp, ratio, del, g1palp + real, parameter :: dz = 200. + + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + real :: alp, diam, diam1, hwdn + +! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp) + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter + real :: cwchtmp,cwchltmp, maxdia + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + integer :: ialp, i, j + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + IF ( lh > 1 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ENDIF + IF ( lhl > 1 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ENDIF + + + kzb = 1 + kze = nz + + ixb = 1 ! aliased its + ixe = nx ! aliased ite + + + jy = jslab + jgs = jy + + +! hailmax1d(:,jy) = 0.0 +! hailmaxk1(:,jy) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + +! first graupel, even if hail is also predicted, since graupel can sometime be large on its own + IF ( lh > 1 .and. lnh > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN + IF ( lvh .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = rho_qh + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,2) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzh > 1 ) THEN ! 3moment + cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.) + ENDIF + diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) + alp = alpha2d(ix,1,kz,2) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF ! lh + +! And diam for hail if present + IF ( lhl > 1 .and. lnhl > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = rho_qhl + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,3) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzhl > 1 ) THEN ! 3moment + cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.) + ENDIF + diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) + alp = alpha2d(ix,1,kz,3) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF + + + END SUBROUTINE HAILMAXD +! ####################################################################### +! ####################################################################### + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & t0,t7,infdo,jslab,its,jts, & & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing ! @@ -3517,7 +4268,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) real dtp real xfall(nx,ny,na) ! array for stuff landing on the ground - real xfall0(nx,ny) ! dummy array +! real xfall0(nx,ny) ! dummy array integer infdo integer jslab ! which line of xfall to use @@ -3525,47 +4276,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. - real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted - real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) - real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) +! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted +! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) +! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - real :: rhovtzx(nz,nx) +! real :: rhovtzx(nz,nx) + + real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + real, allocatable :: rhovtzx(:,:) + real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy double precision :: dt1,dt2,dt3,dt4 - integer,parameter :: ngs = 128 + integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lc:lhab) - real :: zx(ngs,lr:lhab) - logical :: hasmass(nx,lc+1:lhab) - - integer igs(ngs),kgs(ngs) - - real rho0(ngs),temcg(ngs) - - real temg(ngs) - - real rhovt(ngs) - - real cwnc(ngs),cinc(ngs) - real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - - real cimasn,cimasx,cnina(ngs),cimas(ngs) - - real cnostmp(ngs) +! real :: qx(ngs,lv:lhab) +! real :: qxw(ngs,ls:lhab) +! real :: cx(ngs,lc:lhab) +! real :: xv(ngs,lc:lhab) +! real :: vtxbar(ngs,lc:lhab,3) +! real :: xmas(ngs,lc:lhab) +! real :: xdn(ngs,lc:lhab) +! real :: xdia(ngs,lc:lhab,3) +! real :: vx(ngs,li:lhab) +! real :: alpha(ngs,lc:lhab) +! real :: zx(ngs,lr:lhab) +! logical :: hasmass(nx,lc+1:lhab) +! +! integer igs(ngs),kgs(ngs) +! +! real rho0(ngs),temcg(ngs) +! +! real temg(ngs) +! +! real rhovt(ngs) +! +! real cwnc(ngs),cinc(ngs) +! real fadvisc(ngs),cwdia(ngs),cipmas(ngs) +! +! real cimasn,cimasx,cnina(ngs),cimas(ngs) +! +! real cnostmp(ngs) + + real, allocatable :: qx(:,:) + real, allocatable :: qxw(:,:) + real, allocatable :: cx(:,:) + real, allocatable :: xv(:,:) + real, allocatable :: vtxbar(:,:,:) + real, allocatable :: xmas(:,:) + real, allocatable :: xdn(:,:) + real, allocatable :: xdia(:,:,:) + real, allocatable :: vx(:,:) + real, allocatable :: alpha(:,:) + real, allocatable :: zx(:,:) + logical, allocatable :: hasmass(:,:) + + integer, allocatable :: igs(:),kgs(:) + + real, allocatable :: rho0(:),temcg(:) + + real, allocatable :: temg(:) + + real, allocatable :: rhovt(:) + + real, allocatable :: cwnc(:),cinc(:) + real, allocatable :: fadvisc(:),cwdia(:),cipmas(:) + + real, allocatable :: cnina(:),cimas(:) + + real, allocatable :: cnostmp(:) + + real :: cimasn,cimasx !----------------------------------------------------------------------------- @@ -3579,7 +4364,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ################################################################### - + allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) ) + allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ) + allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)) + + ngs = nz+3 + + allocate( qx(ngs,lv:lhab), & + qxw(ngs,ls:lhab), & + cx(ngs,lc:lhab), & + xv(ngs,lc:lhab), & + vtxbar(ngs,lc:lhab,3), & + xmas(ngs,lc:lhab), & + xdn(ngs,lc:lhab), & + xdia(ngs,lc:lhab,3), & + vx(ngs,li:lhab), & + alpha(ngs,lc:lhab), & + zx(ngs,lr:lhab), & + hasmass(nx,lc+1:lhab), & + igs(ngs),kgs(ngs), & + rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), & + cwnc(ngs),cinc(ngs), & + fadvisc(ngs),cwdia(ngs),cipmas(ngs), & + cnina(ngs),cimas(ngs), & + cnostmp(ngs) ) kzb = 1 kze = nz @@ -3717,13 +4525,15 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == n*(n/interval_sedi_vt) ) ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! -! xvt(:,:,:,il) = 0.0 dummy = 0.d0 + + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & @@ -3749,7 +4559,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & + (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) ENDIF @@ -3774,6 +4585,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF +! reflectivity + + IF ( ipconc .ge. 6 ) THEN + IF ( lz(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & an,db1,lz(il),0,xfall,dtz1,ix) + ENDIF + ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' @@ -3787,9 +4606,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & + & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + ! set up for method I+II DO kz = kzb,kze ! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) @@ -3802,7 +4623,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ELSE - + ! set up for method II only DO kz = kzb,kze ! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) @@ -3831,7 +4652,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & - & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) & + .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & tmpn2,db1,1,0,xfall0,dtz1,ix) call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & @@ -3842,12 +4664,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh ) ) THEN + & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN ! "Method I" - dbz correction call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & - & lvol(il), rho_qh, infall, ix) + & lvol(il), xdn0(il), infall, ix) ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN @@ -3858,7 +4680,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDDO ENDDO - ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze @@ -3885,8 +4707,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! ix + deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx ) + deallocate( xfall0, xvt, tmpn ) + deallocate( tmpn2, z) + + deallocate( qx, & + qxw, & + cx, & + xv, & + vtxbar, & + xmas, & + xdn, & + xdia, & + vx, & + alpha, & + zx, & + hasmass, & + igs,kgs, & + rho0,temcg,temg, rhovt, & + cwnc,cinc, & + fadvisc,cwdia,cipmas, & + cnina,cimas, & + cnostmp ) - RETURN END SUBROUTINE SEDIMENT1D @@ -4040,13 +4883,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu jy = jgs ix = ixcol - IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) & + .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN DO kz = 1,kze @@ -4096,16 +4940,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & ENDDO - ELSEIF ( l .eq. lr .and. imurain == 3) THEN + ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN - xdn = 1000. + xdn = rho_qx ! 1000. + IF ( l == ls ) ynu = snu + IF ( l == lr ) ynu = rnu DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) -! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) - z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) + z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ! qr = a(ix,jy,kz,lr) ! nrx = a(ix,jy,kz,lnr) @@ -4319,13 +5166,17 @@ END subroutine calcnfromz1d ! ############################################################################## ! ! Subroutine to calculate number concentrations from initial state that has only mixing ratio. -! N will be in #/kg, NOT #/m^3, since sedimentation is done next. -! +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg ! ! 10.27.2015: Added hail calculation ! - subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + implicit none @@ -4335,6 +5186,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin integer ixe,kze real alpha @@ -4346,7 +5203,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 @@ -4359,11 +5216,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn + real xv,xdn,cwmasinv integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local ! ------------------------------------------------------------------ + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF jy = 1 @@ -4382,18 +5252,59 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF g1s = (snu+2.0)/(snu+1.0) - + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN DO kz = 1,nz DO ix = 1,nx ! ixcol +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + dninv = 1./dn(ix,kz) +! IF ( .not. present( qcw ) ) THEN ! Cloud droplets IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN - an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) @@ -4401,6 +5312,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) IF ( lccna > 1 ) THEN an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF + ENDIF ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN @@ -4449,6 +5361,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. & + an(ix,jy,kz,lnr) > cxmin ) THEN + q = an(ix,jy,kz,lr) + nrx = an(ix,jy,kz,lnr) + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF + ENDIF + ! snow IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN @@ -4511,6 +5432,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. & + an(ix,jy,kz,lnh) > cxmin ) THEN + q = an(ix,jy,kz,lh) + nrx = an(ix,jy,kz,lnh) + an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv + ENDIF + ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -4531,7 +5461,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN @@ -4540,12 +5469,68 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF - - ENDDO ! ix - ENDDO ! kz - - RETURN - + + IF ( lzhl > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. & + an(ix,jy,kz,lnhl) > cxmin ) THEN + q = an(ix,jy,kz,lhl) + nrx = an(ix,jy,kz,lnhl) + an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv + ENDIF + ENDIF + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + + ENDDO ! ix + ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF + + RETURN + END subroutine calcnfromq ! ############################################################################## @@ -4661,6 +5646,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF ENDIF ENDIF @@ -4711,6 +5699,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzh > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF ! @@ -4734,6 +5725,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzhl > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF @@ -4750,7 +5744,9 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3 & + & ,t1,t2,t3,t4,t5,t6, f_t4, f_t5,f_t6 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & & ,an,dn ) implicit none @@ -4766,18 +5762,19 @@ SUBROUTINE calc_eff_radius & ! external temporary arrays ! - real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + logical, optional :: f_t4, f_t5, f_t6 ! flags to fill t4/t5/t6 for rain/graupel/hail - real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - - + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw - ! local real pb(-norz+ng1:nz+norz) @@ -4809,8 +5806,13 @@ SUBROUTINE calc_eff_radius & real :: alpha(ngs,lc:lhab) real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s - real :: lam_c, lam_i, lam_s + real :: lam_c, lam_i, lam_s, lam_r, lam_h, lam_hl + real :: gamr1,gamr2,gamh1,gamh2,factor_r,factor_h,factor_hl integer :: il + real :: hwdn,hldn + double precision :: numh, numhl,denomh,denomhl + + logical :: flag_t4, flag_t5, flag_t6 ! ------------------------------------------------------------------------------- @@ -4825,6 +5827,28 @@ SUBROUTINE calc_eff_radius & nzend = nz kzbeg = 1 nzbeg = 1 + + flag_t4 = .false. + flag_t5 = .false. + flag_t6 = .false. + + IF ( present(f_t4) ) THEN + IF ( present(f_t4) ) THEN + flag_t4 = f_t4 + ENDIF + ENDIF + + IF ( present(f_t5) ) THEN + IF ( present(f_t5) ) THEN + flag_t5 = f_t5 + ENDIF + ENDIF + + IF ( present(f_t6) ) THEN + IF ( present(f_t6) ) THEN + flag_t6 = f_t6 + ENDIF + ENDIF jy = 1 pb(:) = 0.0 @@ -4836,11 +5860,24 @@ SUBROUTINE calc_eff_radius & gami2 = 1. ! Gamma[1 + alphac] gams1 = Gamma_sp(2. + snu) gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + + factor_h = ((Pi*(alphah+3.)*(alphah+1.)*(alphah+1.))/6.)**(1./3.) + factor_hl = ((Pi*(alphahl+3.)*(alphahl+1.)*(alphahl+1.))/6.)**(1./3.) + ! ! jy = 1 ! working on a 2d slab !! VERY IMPORTANT: SET jgs = jy @@ -4852,29 +5889,155 @@ SUBROUTINE calc_eff_radius & DO ix = 1,nx ! ixcol rho0(mgs) = dn(ix,jy,kz) - DO il = lc,ls + IF ( present( an ) ) THEN + DO il = lc,lhab qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) - IF ( qx(mgs,lc) > qxmin(lc) ) THEN + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN ! Lambda for cloud droplets lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF - IF ( qx(mgs,li) > qxmin(li) ) THEN + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN ! Lambda for cloud ice lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF - IF ( qx(mgs,ls) > qxmin(ls) ) THEN + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN ! Lambda for snow lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) t3(ix,jy,kz) = 0.5*factor_s/lam_s ENDIF + IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + + IF ( present(t5) .and. flag_t5 ) THEN + + ! first: case when hail is off + + IF ( lhl < 1 .or. flag_t6 ) THEN + ! graupel only + IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) ) THEN + ! Lambda for graupel + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h + ENDIF + + ELSE ! have hail, too, but do not have t6 array + + IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) < Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for graupel + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h + + ELSEIF ( qx(mgs,lh) < Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for hail + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl + + ELSEIF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! r_eff graupel and hail combined + + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + + numh = cx(mgs,lh)*(alphah+3.)*(alphah+2.)*(alphah+1.)/lam_h**3 + numhl = cx(mgs,lhl)*(alphahl+3.)*(alphahl+2.)*(alphahl+1.)/lam_hl**3 + + denomh = cx(mgs,lh)*(alphah+2.)*(alphah+1.)/lam_h**2 + denomhl = cx(mgs,lhl)*(alphahl+2.)*(alphahl+1.)/lam_hl**2 + + t5(ix,jy,kz) = 0.5*(numh + numhl)/(denomh + denomhl) + + + ENDIF ! no t6 array + + ENDIF ! lhl + + ENDIF ! flag_t5 + + IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN + + IF ( qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for hail + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + t6(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl + + ENDIF + + ENDIF ! t6 + ENDDO ! ix ENDDO ! kz @@ -6172,7 +7335,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -6242,6 +7407,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) + ELSEIF ( icdxhl <= 0 ) THEN ! + aax = ax(lhl) + bbx = bx(lhl) ENDIF ENDIF ! } @@ -6285,7 +7453,6 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & aax = ax(il) vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y ENDIF - ! vtxbar(mgs,il,2) = & ! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & ! & x)/y @@ -6307,7 +7474,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,il,3) = rhovt(mgs)* & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y -! & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y @@ -6549,7 +7716,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real vtmax real xvbarmax - + + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + integer l1, l2 double precision :: dpt1, dpt2 @@ -6825,10 +7996,466 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF + + + IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + + +! +! Set 6th moments +! + IF ( ipconc .ge. 6 .or. lzr > 1) THEN + + zx(:,:) = 0.0 + +! DO il = lr,lhab + DO il = l1,l2 + + IF ( lz(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0) + ENDDO + + + ENDIF + + ENDDO + + ENDIF + + + + +! Find shape parameter rain + + + IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + il = lr + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN +! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) +! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN +! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! tmp = cx(mgs,lr) +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) +! ENDIF + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) +! vr = xv(mgs,lr) + +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! write(91,*) 'alpha = ',alpha(mgs,il) + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 +! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx + + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! +! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + ENDIF + ENDIF + + ENDIF + ENDIF + + ELSE + + zx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ENDIF + + ENDDO + ENDIF ! } + + + IF ( ipconc .ge. 6 ) THEN + +! Find shape parameters for graupel,hail + + DO il = lr,lhab + + IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN +! tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) +! +! ENDIF + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? +! write(91,*) 'ziegfall: something screwy with moments: il = ',il +! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il) +! write(91,*) 'alpha = ',alpha(mgs,il) + + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! write(0,*) 'alpha = ',alpha(mgs,il) + ! set values according to dBZ of -10 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2) + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 +! write(0,*) 'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + +! check for artificial breakup (graupel/hail larger than allowed max size) + + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN + +!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ELSE + ENDIF + ENDIF + ENDDO ! mgs + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + +! CALL cld_cpu('Z-MOMENT-ZFAll') + + ENDIF + IF ( lzhl > 1 ) THEN + IF ( lhl .gt. 1 ) THEN + + ENDIF + ENDIF @@ -6860,6 +8487,19 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN +! IF ( qx(mgs,il) > 1.e-4 .and. & +! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN +! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs +! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg .or. il == lr ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) @@ -6870,6 +8510,18 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & & vtxbar(mgs,il,3) .gt. vtmax ) THEN +! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN +! write(0,*) 'infdo = ',infdo +! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) @@ -7379,6 +9031,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .le. 2 ) THEN gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( lzr .gt. 1 ) THEN + dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr) ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN IF ( imurain == 3 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -7571,7 +9225,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size ! p = 0.106214 for m = p v^(2/3) - dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) IF ( .true. .or. dnsnow < 900. ) THEN gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & @@ -7647,6 +9301,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzh > 1 ) THEN + IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. & + an(ix,jy,kz,lnh) >= cxmin ) ltest = .true. + ENDIF IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN @@ -7692,6 +9350,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzh .gt. 1 ) THEN + x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const + dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmph ELSE g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw @@ -7764,6 +9425,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzhl > 1 ) THEN + IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. & + an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true. + ENDIF IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ chl = an(ix,jy,kz,lnhl) @@ -7787,6 +9452,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzhl .gt. 1 ) THEN !{ + x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const + dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmphl ELSE !} g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) @@ -7895,8 +9563,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'dtmpr = ',dtmpr write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN - write(0,*) 'dbz out of bounds! STOP!' -! STOP + write(0,*) 'dbz out of bounds!' +! STOP ENDIF ENDIF @@ -7937,6 +9605,8 @@ END subroutine radardd02 ! ##################################################################### ! ! Subroutine for explicit cloud condensation and droplet nucleation +! +! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1) ! SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & @@ -7945,6 +9615,7 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -8003,6 +9674,7 @@ SUBROUTINE NUCOND & logical :: io_flag real :: dv + real :: ccnefactwo, sstmp, cn1, cnuctmp ! ! declarations microphysics and for gather/scatter @@ -8011,7 +9683,6 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs - parameter (ngs=500) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -8030,6 +9701,7 @@ SUBROUTINE NUCOND & real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -8042,7 +9714,7 @@ SUBROUTINE NUCOND & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet ! real cnu,rnu,snu,cinu @@ -8160,14 +9832,12 @@ SUBROUTINE NUCOND & real :: cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure integer :: kstag integer :: count - ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -8181,6 +9851,7 @@ SUBROUTINE NUCOND & kzbeg = 1 nzbeg = 1 + IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0)) f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) jy = 1 @@ -8264,7 +9935,7 @@ SUBROUTINE NUCOND & if ( temg(1) .lt. tfr ) then end if ! - if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and. & + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & @@ -8291,6 +9962,7 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -8350,6 +10022,7 @@ SUBROUTINE NUCOND & ELSE ! equation set 2 in cm1 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & @@ -8404,12 +10077,16 @@ SUBROUTINE NUCOND & ELSE ssmax(mgs) = 0.0 ENDIF - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ENDIF ELSE ccnc(mgs) = cwnccn(mgs) ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccncuf(mgs) = 0.0 @@ -8464,8 +10141,239 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn +! Find shape parameter rain -! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM + DO mgs = 1,ngscnt + zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0) + ENDDO + +! CALL cld_cpu('Z-MOMENT-1r2') + il = lr + DO mgs = 1,ngscnt + + IF ( zx(mgs,il) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( cx(mgs,il) <= 0.0 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + + ENDIF +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + + ENDIF + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( imurain == 1 ) THEN + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) +! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z1 = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z1*(pi/6.*1000.)**2/xv + + +! determine shape parameter alpha by iteration + IF ( z1 .gt. 0.0 ) THEN + + IF ( imurain == 3 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + ELSE ! imurain == 1 + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2 + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF +! ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( imurain == 3 ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z1 + ENDIF + ENDIF + + ELSEIF ( imurain == 1 ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + z1 = g1*rho0(mgs)**2*(qr)*qr/nrx + z2 = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z2 + an(igs(mgs),jy,kgs(mgs),lz(il)) = z2 + ENDIF + ENDIF ! imurain + + ENDIF ! z > 0 + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + + ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/y + + + ENDIF + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r2') + ENDIF ! } + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 DO mgs = 1,ngscnt @@ -8483,6 +10391,8 @@ SUBROUTINE NUCOND & ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) +! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs) + ENDDO @@ -8492,7 +10402,7 @@ SUBROUTINE NUCOND & ! cloud water variables ! - if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables' do mgs = 1,ngscnt xv(mgs,lc) = 0.0 @@ -8596,7 +10506,9 @@ SUBROUTINE NUCOND & DO mgs=1,ngscnt dcloud = 0.0 - IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN CYCLE ENDIF @@ -8614,23 +10526,22 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) - thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN - IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) - ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) - ENDIF - ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) + ENDIF ENDIF ENDIF cx(mgs,lc) = 0. @@ -8640,39 +10551,37 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) - ENDIF ENDIF cx(mgs,lc) = 0. ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) ) ELSE - ccnc(mgs) = ccnc(mgs) + tmp + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - tmp - ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF - thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -8954,6 +10863,19 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + ENDIF + zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*f1 ltemq = (temg(mgs)-163.15)/fqsat+1.5 @@ -8995,7 +10917,8 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK - IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -9006,7 +10929,7 @@ SUBROUTINE NUCOND & ELSE dcloud = 0.0 ENDIF - + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -9031,11 +10954,16 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + IF ( ac_opt == 0 ) THEN + cnuctmp = cnuc(mgs) + ELSE + cnuctmp = ccnc_ac(mgs) + ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN ! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 - CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & & .and. ncdebug .ge. 1 ) THEN write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & @@ -9057,12 +10985,16 @@ SUBROUTINE NUCOND & ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) -! ccnc(mgs) = 0.0 + IF ( ac_opt == 0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF + ELSE + cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF @@ -9108,7 +11040,8 @@ SUBROUTINE NUCOND & DSSDZ=0. r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) - IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) IF ( irenuc < 2 ) THEN !{ @@ -9185,6 +11118,7 @@ SUBROUTINE NUCOND & ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) ) IF ( .false. .and. ny <= 2 ) THEN write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn @@ -9212,8 +11146,136 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 3 ) THEN !} { + ! Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck + +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 4 ) THEN !} { + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp +! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs) + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air +! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + + + ELSEIF ( irenuc == 6 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + + ELSE + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + +! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + +! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! +! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! cn(mgs) = 0.0 + ENDIF +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF ELSEIF ( irenuc == 5 ) THEN !} { ! modification of Phillips Donner Garner 2007 @@ -9271,17 +11333,22 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 7 ) THEN !} { + ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) cn(mgs) = 0.0 + IF ( irenuc == 7 ) THEN + frac = 0.9 + ELSE + frac = 0.98 + ENDIF ! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation - IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation - CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN - CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) + CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) !! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN @@ -9319,7 +11386,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) ! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN - IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ENDIF @@ -9421,7 +11488,7 @@ SUBROUTINE NUCOND & IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ! create some small droplets at minimum size (CP 2000), although it adds very little liquid @@ -9440,8 +11507,6 @@ SUBROUTINE NUCOND & ccna(mgs) = ccna(mgs) + cn(mgs) - - ENDIF ! irenuc >= 0 .and. .not. flag_qndrop IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. @@ -9494,7 +11559,11 @@ SUBROUTINE NUCOND & ELSEIF ( imaxsupopt == 4 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) ENDIF - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) + cn(mgs) + ELSE + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ENDIF @@ -9599,15 +11668,21 @@ SUBROUTINE NUCOND & ! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) end if + IF ( lzr > 1 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 ) + ENDIF IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) - IF ( lccn .gt. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + IF ( ac_opt == 0 ) THEN + IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) ENDIF IF ( lccna .gt. 1 ) THEN @@ -9684,6 +11759,42 @@ SUBROUTINE NUCOND & IF ( lhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN + + an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment + + IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + chw = an(ix,jy,kz,lnhl) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl) + ENDIF + ENDIF + + ENDIF !lzhl if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then @@ -9703,6 +11814,10 @@ SUBROUTINE NUCOND & IF ( lhlw .gt. 1 ) THEN an(ix,jy,kz,lhlw) = 0.0 ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 @@ -9780,13 +11895,49 @@ SUBROUTINE NUCOND & + IF ( lzh .gt. 1 ) THEN - if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then - -! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) - an(ix,jy,kz,lh) = 0.0 -! ENDIF + an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) + + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN + + IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + + chw = an(ix,jy,kz,lnh) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) ) + + IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh) + ENDIF + ENDIF + + ENDIF + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN an(ix,jy,kz,lnh) = 0.0 @@ -9799,6 +11950,10 @@ SUBROUTINE NUCOND & IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 @@ -9936,6 +12091,9 @@ SUBROUTINE NUCOND & end if + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) + ENDIF if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & & ) then @@ -9946,6 +12104,10 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = 0.0 + ENDIF + end if ! @@ -9998,18 +12160,25 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lc)= 0.0 IF ( ipconc .ge. 2 ) THEN - IF ( lccn .gt. 1 ) THEN - an(ix,jy,kz,lccn) = & - & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN + IF ( irenuc < 5 .and. lccna <= 1 ) THEN + IF ( ac_opt == 0 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + ELSEIF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 + IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) - - ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ENDIF + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) ! IF ( ny == 2 .and. ix == nx/2 ) THEN @@ -10071,8 +12240,9 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & - & , has_wetscav,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d, alpha2d & & ,elec,its,ids,ide,jds,jde & & ) @@ -10153,9 +12323,17 @@ subroutine nssl_2mom_gs & integer :: my_rank = 0 integer, parameter :: myprock = 1, nprock = 1 logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) + + real, parameter :: tfrdry = 243.15 + + logical lrescalelow(lc:lhab) real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -10192,7 +12370,6 @@ subroutine nssl_2mom_gs & logical, parameter :: usegamxinf3 = .false. ! real rar ! rime accretion rate as calculated from qxacw - ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -10299,7 +12476,6 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs - parameter (ngs=500) !500) integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -10362,7 +12538,8 @@ subroutine nssl_2mom_gs & real ex1, ft, rhoinv(ngs) double precision ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim real dw,dwr double precision :: tmpz, tmpzmlt real ratio, delx, dely @@ -10443,7 +12620,7 @@ subroutine nssl_2mom_gs & real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real elv(ngs),elf(ngs),els(ngs) - real tsqr(ngs),ssi(ngs),ssw(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs) real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp @@ -10458,6 +12635,7 @@ subroutine nssl_2mom_gs & parameter ( rwradmn = 50.e-6 ) real dh0 real dg0(ngs),df0(ngs) + real dhwet(ngs),dhlwet(ngs),dfwet(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10465,7 +12643,7 @@ subroutine nssl_2mom_gs & ! other arrays real fwet1(ngs),fwet2(ngs) - real fmlt1(ngs),fmlt2(ngs) + real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) ! @@ -10483,13 +12661,13 @@ subroutine nssl_2mom_gs & real cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure ! real fcci(ngs), fcip(ngs) ! real :: sfm1(ngs),sfm2(ngs) real :: gfm1(ngs),gfm2(ngs) + real :: ffm1(ngs),ffm2(ngs) real :: hfm1(ngs),hfm2(ngs) logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) @@ -10519,6 +12697,7 @@ subroutine nssl_2mom_gs & real :: vtxbar(ngs,lc:lhab,3) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) real :: cdxgs(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter @@ -10529,6 +12708,10 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) + real :: zx(ngs,lr:lhab) + real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10544,6 +12727,7 @@ subroutine nssl_2mom_gs & real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr + real g1smlr, alphasmlr real massfacshr, massfacmlr real :: qhgt8mm ! ice mass greater than 8mm @@ -10556,6 +12740,8 @@ subroutine nssl_2mom_gs & real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + real hxventtmp + real hlventinc(ngs),hwventinc(ngs) integer, parameter :: ndiam = 10 integer :: numdiam real hwvent0(ndiam+4),hlvent0 ! 0 to d1 @@ -10643,6 +12829,7 @@ subroutine nssl_2mom_gs & real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) ! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) real chlshr(ngs), chlshrr(ngs) @@ -10668,15 +12855,15 @@ subroutine nssl_2mom_gs & real qrcnw(ngs), qwcnr(ngs) real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) - real qracw(ngs) ! qwacr(ngs), real qiacw(ngs) !, qwaci(ngs) real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! + real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10685,7 +12872,7 @@ subroutine nssl_2mom_gs & ! arrays for x-ac-r and r-ac-x; ! real qsacr(ngs),qracs(ngs) - real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) @@ -10693,7 +12880,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) + real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -10739,7 +12926,8 @@ subroutine nssl_2mom_gs & real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) +! real zsmlr(ngs) + real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes @@ -10780,9 +12968,10 @@ subroutine nssl_2mom_gs & ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) - real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp ! real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) + real :: qffz(ngs) ! real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) @@ -10792,6 +12981,7 @@ subroutine nssl_2mom_gs & real qhshh(ngs) !accreted water that remains on graupel real qhmlh(ngs) !melt water that remains on graupel real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qffzf(ngs) !water that freezes on mixed-phase FD real qhlfzhl(ngs) !water that freezes on mixed-phase hail real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters @@ -10843,6 +13033,7 @@ subroutine nssl_2mom_gs & real qrshr(ngs) real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real ffwmax(ngs) real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) @@ -10856,7 +13047,7 @@ subroutine nssl_2mom_gs & real ehxr(ngs),ehlr(ngs),egmr(ngs) real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) - real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) @@ -10915,12 +13106,13 @@ subroutine nssl_2mom_gs & real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), - real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs) real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + real pvhwi(ngs), pvhwd(ngs) real pvfwi(ngs), pvfwd(ngs) @@ -10932,7 +13124,7 @@ subroutine nssl_2mom_gs & real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) real pqird(ngs),pqipd(ngs) ! pqwad(ngs), - real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs) ! ! real pqxii(ngs,nhab),pqxid(ngs,nhab) ! @@ -11036,8 +13228,8 @@ subroutine nssl_2mom_gs & real arg ! gamma is a function real erbnd1, fdgt1, costhe1 real qeps - real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii - real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] @@ -11080,7 +13272,7 @@ subroutine nssl_2mom_gs & real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 - real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 real a1,a2,a3,a4,a5,a6 @@ -11112,9 +13304,22 @@ subroutine nssl_2mom_gs & real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation + real :: cwchtmp + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail +! inline functions for Newton method + real :: galpha, dgalpha + real :: a_in + logical, parameter :: newton = .false. + + + galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & + & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) ! ! #################################################################### ! @@ -11144,6 +13349,11 @@ subroutine nssl_2mom_gs & jstag = 0 kstag = 1 + lrescalelow(:) = rescale_low_alpha + lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha + lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha + IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha + IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha ! @@ -11200,7 +13410,7 @@ subroutine nssl_2mom_gs & ! constants ! - cp608 = 0.608 +! cp608 = 0.608 aradcw = -0.27544 bradcw = 0.26249e+06 cradcw = -1.8896e+10 @@ -11231,7 +13441,7 @@ subroutine nssl_2mom_gs & gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) gf3ds = 3.0458730354120997 ! gamma(3.0+ds) gf1ds = 0.8863557896089221 ! gamma(1.0+ds) - gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) @@ -11261,11 +13471,18 @@ subroutine nssl_2mom_gs & vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) - snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + IF ( snowmeltdia > 0.0 ) THEN + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + ENDIF tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi + + IF ( mixedphase ) THEN + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF ! ! ! #ifdef COMMAS @@ -11417,35 +13634,25 @@ subroutine nssl_2mom_gs & do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) -! pqs(kz) = t00(ix,jy,kz) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) temcg(1) = temg(1) - tfr tqvcon = temg(1)-cbw - ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = (temg(1)-163.15)/fqsat + 1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN + qis(1) = pqs(1)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(1) = pqs(1)*tabqis(ltemq) + ENDIF qss(1) = qvs(1) -! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN -! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) -! ENDIF - if ( temg(1) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) - qss(1) = qis(1) - else -! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN -! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) -! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) -! ENDIF + qss(1) = qis(1) end if ! ishail = .false. @@ -11521,7 +13728,12 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ENDIF qss(mgs) = qvs(mgs) ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! eis(mgs) = 6.1078e2*tabqis(ltemq) @@ -11562,78 +13774,6 @@ subroutine nssl_2mom_gs & - scx(:,:) = 0.0 -! -! set shape parameters -! - IF ( imurain == 1 ) THEN - alpha(:,lr) = alphar - ELSEIF ( imurain == 3 ) THEN - alpha(:,lr) = xnu(lr) - ENDIF - - alpha(:,li) = xnu(li) - alpha(:,lc) = xnu(lc) - - IF ( imusnow == 1 ) THEN - alpha(:,ls) = alphas - ELSEIF ( imusnow == 3 ) THEN - alpha(:,ls) = xnu(ls) - ENDIF - - DO il = lr,lhab - do mgs = 1,ngscnt - IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - - - DO ic = lc,lhab - dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) - ENDDO - ENDDO - end do - - -! DO mgs = 1,ngscnt - DO il = lr,lhab - da0lx(:,il) = da0(il) - ENDDO - da0lh(:) = da0(lh) - da0lr(:) = da0(lr) - da1lr(:) = da1(lr) - da0lc(:) = da0(lc) - da1lc(:) = da1(lc) - - - IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz - ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN - rzxhlh(:) = 1. - ENDIF - IF ( lzr > 1 ) THEN - rzxh(:) = 1. - rzxhl(:) = 1. - ELSE - rzxh(:) = rz - rzxhl(:) = rzhl - ENDIF - - IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN - rzxs(:) = rzs - ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN - rzxs(:) = 1. - ENDIF - ! ENDDO - - IF ( lhl .gt. 1 ) THEN - DO mgs = 1,ngscnt - da0lhl(mgs) = da0(lhl) - ENDDO - ENDIF - - ventrx(:) = ventr - ventrxn(:) = ventrn - gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set concentrations @@ -11802,6 +13942,124 @@ subroutine nssl_2mom_gs & +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + zx(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + DO mgs = 1,ngscnt + zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + ENDDO + ENDIF + ENDDO + + ENDIF + + IF ( ipconc .ge. 6 ) THEN + + IF ( lz(lr) .lt. 1 ) THEN + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + + + DO mgs = 1,ngscnt + IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0) + ELSE ! imurain == 1 + zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 + ENDIF + ENDIF + + ENDIF + ENDDO + ENDIF + + ENDIF + + + scx(:,:) = 0.0 +! +! set shape parameters +! + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha' + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab' + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + end do + ENDDO + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz' + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set factors @@ -11840,6 +14098,7 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -11962,6 +14221,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) IF ( lvol(lhl) .gt. 1 ) THEN IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -11973,6 +14233,7 @@ subroutine nssl_2mom_gs & xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value @@ -11986,33 +14247,851 @@ subroutine nssl_2mom_gs & end do + IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN - IF ( imurain == 3 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 0.0 - alphamlr = -2.0/3.0 - ELSE - alphashr = xnu(lr) - alphamlr = xnu(lr) - ENDIF -! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor -! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) - massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor - massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) - ELSEIF ( imurain == 1 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 4.0 - alphamlr = 4.0 - ELSE - alphashr = alphar - alphamlr = alphar - ENDIF -! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor -! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + + DO mgs = 1,ngscnt + !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. + + ! M&M-C 2010: + tmp = 4. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp + + alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN +! MY 2005: + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) +! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + + ! M&M-C 2010: + tmp = 4. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp + + alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ! alphan(mgs,lh) = alpha(mgs,lh) + + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. + il = lh + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + + il = lhl + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + + ENDIF + ENDIF + + + + ENDDO + ENDIF + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + alphasmlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + alphasmlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + alphasmlr = alphasmlr0 + ELSE + alphashr = alphar + alphamlr = alphar + alphasmlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF +! Find shape parameter rain + + g1shr = 1.0 + g1mlr = 1.0 + g1smlr = 1.0 + +! CALL cld_cpu('Z-MOMENT-1') + + IF ( ipconc >= 6 ) THEN + + ! set base g1x in case rain is not 3-moment + IF ( ipconc >= 6 .and. imurain == 3 ) THEN + il = lr + DO mgs = 1,ngscnt +! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)) + ENDDO + ENDIF + + IF (lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + g1shr = (alphashr+2.0)/((alphashr+1.0)) + g1mlr = (alphamlr+2.0)/((alphamlr+1.0)) + g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0)) + ELSEIF ( imurain == 1 ) THEN +! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & +! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) + g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & + & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) +! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & +! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & + & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ & + & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr)) + ENDIF + ENDIF + + IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + + +! CALL cld_cpu('Z-MOMENT-1r') + il = lr + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN + + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN + tmp = cx(mgs,il) + IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. + IF ( alp >= rnumax - 0.01 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + +! This whole section is imurain == 3, so this branch never runs +! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN +! +! tmp = alpha(mgs,lr) + 2.5 + br/2. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrxn(mgs) = x/y + + + ENDIF + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + ENDIF ! } + + ENDIF ! ipconc >= 6 + +! Find shape parameters for graupel and hail + IF ( ipconc .ge. 6 ) THEN + + DO il = lr,lhab + + ! set base values of g1x + IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN + DO mgs = 1,ngscnt + g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + ENDDO + ENDIF + + IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSE + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + alp = Max( alphamin, Min( alphamax, alp ) ) + + IF ( newton ) THEN + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = alp + ( galpha(alp) - rdi )/dgalpha(alp) + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + ELSE + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + ENDIF + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN + tmp = cx(mgs,il) + IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest ) ) THEN +! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ENDIF + + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. +! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2 +! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2 + IF ( alp >= alphamax - 0.5 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + ENDIF + +! IF ( ny .eq. 2 ) THEN +! IF ( qr .gt. 1.e-3 ) THEN +! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000. +! ENDIF +! ENDIF + + + ENDIF ! .true. + + IF ( il == lr ) THEN + +! tmp = alpha(mgs,lr) + 4./3. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +! tmp = alpha(mgs,lr) + 1. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + + IF ( iferwisventr == 2 ) THEN + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + + ventrxn(mgs) = x/y + + ENDIF + + ENDIF ! il==lr + + + ELSE ! below mass threshold +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) +! z1 = g1*rho0(mgs)**2*(qr)*qr/chw +! z = 1.e18*z1*(6./(pi*1000.))**2 +! z = z1*(6./(pi*1000.))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF ! ( qx(mgs,il) .gt. qxmin(il) ) + + + +! ENDIF + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + +! IF ( il == lr ) THEN +! xnutmp = (alpha(mgs,il) - 2.)/3. +! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) +! ENDIF + + IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN +! CALL cld_cpu('Z-DELABK') + DO mgs = 1,ngscnt + IF ( qx(mgs,il) > qxmin(il) ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + +! IF ( .true. ) THEN + DO ic = lc,lh-1 ! lhab + IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN + xnuc = xnu(ic) + IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu + IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + xnuc = alpha(mgs,lr) ! alpha is nu already + ELSE + xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu + ENDIF + ENDIF + ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected + IF ( .false. ) THEN + dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic) + dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic) + dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) + dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + +! tmp1 = dab0lu(j,i,ic,il) +! tmp2 = dab1lu(j,i,ic,il) +! tmp3 = dab0lu(i,j,il,ic) +! tmp4 = dab1lu(i,j,il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) + write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic) + write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j + write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1 + write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2 + write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5 + write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6 + + ENDIF + + ENDIF + + ENDIF + ENDDO + +! ENDIF + + da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( il .eq. lh ) THEN + da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxh(mgs) = 1. + ELSE + rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + + IF ( lzhl < 1 ) THEN + rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) + ENDIF + ELSEIF ( il .eq. lhl ) THEN + da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxhl(mgs) = 1. + ELSE + rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + ELSEIF ( il == lr ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1) + ENDIF + + ENDIF ! ( qx(mgs,il) > qxmin(il) ) + ENDDO ! mgs +! CALL cld_cpu('Z-DELABK') + ENDIF ! il /= lr + +! CALL cld_cpu('Z-DELABK') + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + + ENDIF ! ipconc .ge. 6 + +! CALL cld_cpu('Z-MOMENT-1') ! ! set some values for ice nucleation @@ -12044,7 +15123,7 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) - infdo = 0 + infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & @@ -12058,9 +15137,9 @@ subroutine nssl_2mom_gs & IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt - sum = qx(mgs,lh) + qx(mgs,ls) - IF ( sum > tmp ) THEN - vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + total = qx(mgs,lh) + qx(mgs,ls) + IF ( total > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total ELSE vt2ave(mgs) = 0.0 ENDIF @@ -12206,6 +15285,17 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN + frac = 0.4d0 + zxmxd(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) > 0 .or. ( il == lr ) ) THEN + DO mgs = 1,ngscnt + zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv + ENDDO + ENDIF + ENDDO + ENDIF @@ -12243,10 +15333,10 @@ subroutine nssl_2mom_gs & vshdgs(mgs,il) = vshd ! base value - IF ( qx(mgs,il) > qxmin(il) ) THEN + IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. - tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice @@ -12303,13 +15393,13 @@ subroutine nssl_2mom_gs & ers(mgs) = 0.0 ess(mgs) = 0.0 ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehsfac(mgs) = 1.0 ! factor based on ice saturation ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn ehscnv(mgs) = 0.0 ! ehxs(mgs) = 0.0 ! eiw(mgs) = 0.0 eii(mgs) = 0.0 - ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -12404,7 +15494,7 @@ subroutine nssl_2mom_gs & if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then + if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then eiw(mgs) = 0.5 @@ -12528,7 +15618,7 @@ subroutine nssl_2mom_gs & ELSE fac = Abs(ess0) - IF ( .true. .and. ess0 < 0.0 ) THEN + IF ( iessopt == 2 ) THEN ! experimental code ! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN IF ( wvel(mgs) > 2.0 ) THEN ! assume convective cell or downdraft @@ -12536,9 +15626,25 @@ subroutine nssl_2mom_gs & ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values fac = Max(0.0, 2.0 - wvel(mgs))*fac ENDIF + ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.0 + ehsfac(mgs) = 0.0 + ELSEIF ( ssi(mgs) <= 1.02 ) THEN + fac = fac*(ssi(mgs) - 1.0)/0.02 + ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02 + ENDIF + ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) <= 1.005 ) THEN + fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF ENDIF - IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) @@ -12649,7 +15755,11 @@ subroutine nssl_2mom_gs & ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + + IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN +! ehsclsn(mgs) = ehs_collsn +! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) +! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then ehsclsn(mgs) = ehs_collsn IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN ehsclsn(mgs) = 0.0 @@ -12659,9 +15769,9 @@ subroutine nssl_2mom_gs & ehsclsn(mgs) = ehs_collsn ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density - ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) - IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if ENDIF ! @@ -12669,7 +15779,7 @@ subroutine nssl_2mom_gs & ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 end if IF ( lis > 1 ) THEN @@ -12677,7 +15787,7 @@ subroutine nssl_2mom_gs & ehisclsn(mgs) = ehi_collsn ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 end if ENDIF @@ -12814,6 +15924,7 @@ subroutine nssl_2mom_gs & end do + ! ! ! @@ -12887,6 +15998,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qraci(mgs) = 0.0 craci(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN IF ( ipconc .ge. 3 ) THEN @@ -12932,8 +16044,9 @@ subroutine nssl_2mom_gs & ENDIF end do ! + IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt - qracs(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) @@ -12950,6 +16063,7 @@ subroutine nssl_2mom_gs & & , qsmxd(mgs)) ENDIF end do + ENDIF ! ! @@ -13096,6 +16210,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qhacw(mgs) = 0.0 + qhacwmlr(mgs) = 0.0 rarx(mgs,lh) = 0.0 vhacw(mgs) = 0.0 vhsoak(mgs) = 0.0 @@ -13162,6 +16277,11 @@ subroutine nssl_2mom_gs & ENDIF + qhacwmlr(mgs) = qhacw(mgs) + IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN + qhacw(mgs) = 0.0 + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail IF ( temg(mgs) .lt. 273.15) THEN @@ -13191,14 +16311,18 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13412,6 +16536,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qhlacw(mgs) = 0.0 + qhlacwmlr(mgs) = 0.0 vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN @@ -13440,10 +16565,15 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + qhlacwmlr(mgs) = qhlacw(mgs) + IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN + qhlacw(mgs) = 0.0 + ENDIF + IF ( lvol(lhl) .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN - IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985) rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & & /(temg(mgs)-273.15))**(rimc2) @@ -13457,13 +16587,17 @@ subroutine nssl_2mom_gs & rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13778,7 +16912,7 @@ subroutine nssl_2mom_gs & frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) - ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs) ENDIF ENDIF @@ -13808,7 +16942,7 @@ subroutine nssl_2mom_gs & tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass IF ( tmp .lt. essfrac1 ) THEN ec0(mgs) = 1.0 - ELSEIF ( tmp .gt. essfrac2 ) THEN + ELSEIF ( tmp .ge. essfrac2 ) THEN ec0(mgs) = 0.0 ELSE ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) @@ -13885,7 +17019,21 @@ subroutine nssl_2mom_gs & ec0(mgs) = 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) - IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + + + ! check median volume diameter + IF ( icracrthresh > 1 ) THEN + IF ( imurain == 1 ) THEN + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) + ELSE ! imurain == 3, + tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb) + ENDIF + ELSE + tmp = xdia(mgs,lr,3) - 0.1e-3 + ENDIF + +! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 ELSE @@ -13967,6 +17115,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' chaci(:) = 0.0 + chaci0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN @@ -14017,6 +17166,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' chacs(:) = 0.0 + chacs0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehs(mgs) .gt. 0 ) THEN @@ -14176,7 +17326,7 @@ subroutine nssl_2mom_gs & ! Ziegler (1985) autoconversion ! ! - IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + IF ( ipconc .ge. 2 ) THEN if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt @@ -14196,7 +17346,7 @@ subroutine nssl_2mom_gs & cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) cautn(mgs) = Max( 0.0d0, cautn(mgs) ) - IF ( rb(mgs) .le. 7.51d-6 ) THEN + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN t2s = 1.d30 ! cautn(mgs) = 0.0 ELSE @@ -14259,6 +17409,47 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( ipconc >= 6 ) THEN + IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN +! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs)) +! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2) + ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1) + ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2) + ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok. + IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN + tmp3 = qx(mgs,lr)/cx(mgs,lr) + tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + if (imurain == 3) then + vr = rho0(mgs)*qrcnw(mgs)/(1000.) + tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + else + tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + endif + IF ( dmrauto == 1 ) THEN ! Preserve alpha + zrcnw(mgs) = tmp4 + ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average + zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ENDIF + else ! original formulation + IF ( imurain == 3 ) THEN + vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator + zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ELSE ! rain in gamma of diameter + IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN + zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + ELSE + tmp3 = qx(mgs,lr)/cx(mgs,lr) + zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + ENDIF +! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator +! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ENDIF + endif +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + ENDIF + ENDIF ! ipconc >= 6 ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -14469,6 +17660,15 @@ subroutine nssl_2mom_gs & ELSE !{ + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + ENDIF IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -14478,6 +17678,10 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! @@ -14489,6 +17693,10 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 + IF (ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSE !{ ! recalculate using dhmn for ratio @@ -14528,10 +17736,23 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) + zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) + ENDIF ENDIF ! } ELSE crfrzs(mgs) = 0.0 qrfrzs(mgs) = 0.0 + zrfrzs(mgs) = 0.0 ENDIF ! } ENDIF !} @@ -14544,6 +17765,10 @@ subroutine nssl_2mom_gs & crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrz(mgs) = fac*zrfrz(mgs) + zrfrzf(mgs) = fac*zrfrzf(mgs) + ENDIF ENDIF ENDIF !} @@ -15088,8 +18313,16 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) - IF ( lzr > 1 ) THEN ! 3 moment -! + IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment + tmp = 1. + alpr ! alpha(mgs,lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions ELSE y = ventrxn(mgs) ENDIF @@ -15105,6 +18338,13 @@ subroutine nssl_2mom_gs & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + rwventz(mgs) = 0.0 + +! rwventz(mgs) = & +! & 0.78*x + & +! & 0.308*fvent(mgs)*y* & +! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + ELSEIF ( iferwisventr == 2 ) THEN @@ -15117,6 +18357,23 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) + + tmp = alpr + 5.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! rwventz(mgs) = & +! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + & + rwventz(mgs) = & + & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + & + & 0.308*fvent(mgs)* & + & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0)) + + ENDIF + ENDIF ! iferwisventr @@ -15159,6 +18416,9 @@ subroutine nssl_2mom_gs & hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) ! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + hwvent(:) = 0.0 + hwventy(:) = 0.0 + do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) @@ -15279,6 +18539,8 @@ subroutine nssl_2mom_gs & & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & & / (felf(mgs)) fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + fmlt1e(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs)) end do ! ! Vapor Deposition constants @@ -15306,6 +18568,7 @@ subroutine nssl_2mom_gs & qhlmlrlg(:) = 0.0 ENDIF qhfzh(:) = 0.0 + qffzf(:) = 0.0 qhlfzhl(:) = 0.0 qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 @@ -15313,9 +18576,10 @@ subroutine nssl_2mom_gs & vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 - zsmlr(:) = 0.0 +! zsmlr(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 + zsmlrr(:) = 0.0 zhshr(:) = 0.0 zhlmlr(:) = 0.0 zhlshr(:) = 0.0 @@ -15329,6 +18593,7 @@ subroutine nssl_2mom_gs & chmlr(:) = 0.0 chmlrr(:) = 0.0 chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 ! chlmlrsave(:) = 0.0 ! qhlmlrsave(:) = 0.0 ! chlsave(:) = 0.0 @@ -15366,7 +18631,7 @@ subroutine nssl_2mom_gs & qhmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & - & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results @@ -15397,13 +18662,13 @@ subroutine nssl_2mom_gs & qhlmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & - & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef Z3MOM -! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) +! #ifdef 1 +! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results @@ -15434,7 +18699,7 @@ subroutine nssl_2mom_gs & chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) ENDIF ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion - qhmlh(mgs) = 0. + qhmlh(mgs) = 0. ! not used ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding @@ -15511,8 +18776,15 @@ subroutine nssl_2mom_gs & ! ENDIF - IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = alpha(mgs,lh) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + + ENDIF IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN @@ -15618,6 +18890,17 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN + IF ( cx(mgs,lhl) > 0.0 ) THEN + + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = alpha(mgs,lhl) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) + ENDIF + ENDIF ENDIF ! } ENDIF ! }.not. mixedphase @@ -15655,6 +18938,7 @@ subroutine nssl_2mom_gs & ENDDO ! ! + qhdsv(:) = 0.0 qhldsv(:) = 0.0 do mgs = 1,ngscnt @@ -15664,6 +18948,7 @@ subroutine nssl_2mom_gs & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac + ! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) ! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN ! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), @@ -15900,20 +19185,41 @@ subroutine nssl_2mom_gs & ! end of qlimit + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 qidpv(mgs) = 0.0 qsdpv(mgs) = 0.0 + qhsbv(mgs) = 0.0 + qscev(mgs) = 0.0 + cscev(mgs) = 0.0 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN + ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + ENDIF + + IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) +! qhcev(mgs) = & +! & evapfac*min( & +! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 ) + + qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) + IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) ) + + ENDIF + ENDIF qhlsbv(mgs) = 0.0 qhldpv(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) + qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) + IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) ) + + ENDIF + ENDIF ENDIF temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) @@ -16068,6 +19407,10 @@ subroutine nssl_2mom_gs & end if end do + + + + ! ! ! compute dry growth rate of snow, graupel, and hail @@ -16094,7 +19437,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( temg(mgs) < tfr ) THEN + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -16105,31 +19448,39 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE + IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) qhwet(mgs) = max( 0.0, qhwet(mgs)) + ELSE + ENDIF + ! ENDIF qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - qhlwet(mgs) = & - & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & - & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) - qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + IF ( incwet == 0 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + + ELSE + ENDIF ! incwet ENDIF ELSE qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF ! ! qhlwet(mgs) = qhldry(mgs) end do + ! ! shedding rate ! @@ -16189,7 +19540,7 @@ subroutine nssl_2mom_gs & qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) ELSE ! new and correct - + ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) @@ -16280,6 +19631,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + rimdn(mgs,lh) = xdnmx(lh) raindn(mgs,lh) = xdnmx(lh) vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) @@ -16293,7 +19646,10 @@ subroutine nssl_2mom_gs & v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion vhsoak(mgs) = Min(v1,v2) + + ENDIF + ENDIF vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) @@ -16349,6 +19705,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + IF ( iwetsoak ) THEN + rimdn(mgs,lhl) = xdnmx(lhl) raindn(mgs,lhl) = xdnmx(lhl) vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) @@ -16372,6 +19730,8 @@ subroutine nssl_2mom_gs & ! vhlacw(mgs) = 0.0 ! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) @@ -16516,7 +19876,93 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF - dg0(mgs) = -1. + IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN + dg0(mgs) = -1. + ELSE + IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + sqrtrhovt = Sqrt( rhovt(mgs) ) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + ltemq = (tfr-163.15)/fqsat+1.5 + qvs0 = pqs(mgs)*tabqvs(ltemq) + denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) + denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option + x1 = fventm*sqrtrhovt*Sqrt(d*vth) + IF ( x1 > 1.4 ) THEN + am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8) + ELSE + am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ & + (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp)) + + ELSE + + ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0 + ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc. + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + ENDIF + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ELSE + IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN + dg0(mgs) = dwmax + ELSE + dg0(mgs) = dg0thresh + 0.0001 + ENDIF + ENDIF + + IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .le. tfr-2.0 ) THEN + ! set a secondary condition on to capture large graupel that is riming but not in wet growth + dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + ENDIF + + ENDIF wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) @@ -16551,18 +19997,6 @@ subroutine nssl_2mom_gs & tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) ! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) -! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN -! hdia1 = Max(dh0, xdia(mgs,lh,3) ) -! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & -! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & -! & *exp(-hdia1/xdia(mgs,lh,1)) & -! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & -! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - -! ENDIF - -! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) -! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -16572,8 +20006,6 @@ subroutine nssl_2mom_gs & chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter -! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) -! chlcnh(mgs) = Min( chlcnh(mgs), r ) chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF !} @@ -16588,12 +20020,119 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + ! dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + flim = 1.0 + tmp3 = qxmxd(mgs,lh) + IF (qxd1 > tmp3 ) THEN +! flim = tmp3/(qxd1) +! qhlcnh(mgs) = flim*qhlcnh(mgs) + ENDIF + + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF + cxd1 = flim*cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( tmp < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + ! reflectivity + IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = flim*zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} ENDDO ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion +! +! Staka and Mansell (2005) type conversion +! +! hldia1 is set in micro_module and namelist +! IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + ! reflectivity + IF ( lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO +! ENDIF ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -16829,6 +20368,10 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) +! IF ( lzh .gt. 1 ) THEN +! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & +! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) +! ENDIF vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) @@ -16868,7 +20411,13 @@ subroutine nssl_2mom_gs & IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN ! qrcev(mgs) = -qrmxd(mgs) ! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) - crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + IF ( icrcev == 1 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSEIF ( icrcev == 2 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1) + ELSE + crcev(mgs) = 0.0 + ENDIF ELSE crcev(mgs) = 0.0 ENDIF @@ -16880,12 +20429,6 @@ subroutine nssl_2mom_gs & ! ! evaporation/condensation of wet graupel and snow ! - qscev(:) = 0.0 - cscev(:) = 0.0 - qhcev(:) = 0.0 - chcev(:) = 0.0 - qhlcev(:) = 0.0 - chlcev(:) = 0.0 IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -16895,6 +20438,7 @@ subroutine nssl_2mom_gs & chlcevlg(:) = 0.0 ENDIF + ! ! ! @@ -17711,9 +21255,11 @@ subroutine nssl_2mom_gs & & + chsbv(mgs) & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + ! ! @@ -17840,6 +21386,14 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN + pzhwi(:) = 0.0 + pzhwd(:) = 0.0 + pzrwi(:) = 0.0 + pzrwd(:) = 0.0 + pzhli(:) = 0.0 + pzhld(:) = 0.0 + ENDIF ! @@ -18078,7 +21632,8 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) -! qhcev(mgs) = frac*qhcev(mgs) + qhcev(mgs) = frac*qhcev(mgs) + qhlcev(mgs) = frac*qhlcev(mgs) IF ( warmonly < 0.5 ) THEN @@ -18124,6 +21679,8 @@ subroutine nssl_2mom_gs & ! STOP ENDIF + + end do IF ( warmonly < 0.5 ) THEN @@ -18152,7 +21709,7 @@ subroutine nssl_2mom_gs & & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & - & + (qssbv(mgs)) & + & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) @@ -18267,53 +21824,634 @@ subroutine nssl_2mom_gs & & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included end do -! -! Hail -! - IF ( lhl .gt. 1 ) THEN +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Graupel reflectivity +! + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' + + do mgs = 1,ngscnt + +! zhmlr(mgs) = 0.0 +! zhshr(mgs) = 0.0 +! zhmlrr(mgs) = 0.0 +! zhshrr(mgs) = 0.0 + zhdsv(mgs) = 0.0 +! IF ( lf < 1 ) THEN + IF ( ffrzh > 0.0 ) THEN + ziacr(mgs) = 0.0 + ziacrf(mgs) = 0.0 + ENDIF +! ENDIF + zhcns(mgs) = 0.0 + zhcni(mgs) = 0.0 + zhacs(mgs) = 0.0 + zhaci(mgs) = 0.0 + + ENDDO + + IF ( lzh .gt. 1 ) THEN ! + do mgs = 1,ngscnt + + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = Max( alphamin, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) ) + zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) + + IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + ENDIF + + zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + +! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN + IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN +! IF ( temg(mgs) > tfr + 2.0 ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) +! IF ( zhshrr(mgs) > 0. ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) +! ENDIF +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) +! ELSE +! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + + + IF ( temg(mgs) >= tfr ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) + ! IF ( zhshrr(mgs) > 0.0 ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? + ENDIF + zhshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) + ELSE + zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ENDIF + + zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) + ENDIF + + IF ( zhshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) + write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + + STOP + ENDIF + + +! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) + + qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs) + ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs) + + zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhacr(mgs) .gt. 0.0 ) THEN +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) +! zhacrf(mgs) = g1*zhacr + + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) + + IF ( z > zx(mgs,lh) ) THEN +! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv + ELSE +! zhacr(mgs) = 0.0 + ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( qhacw(mgs) .gt. 0.0 ) THEN +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) + IF ( z > zx(mgs,lh) ) THEN +! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ELSE ! } { ! this is not used because of the 'true' above + + IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + IF ( z > zx(mgs,lh) ) THEN + zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN + zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) + ENDIF + ENDIF +! qsplinter(mgs) + IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + ! note that 3.6476 = (6/pi)**2 + ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ELSE ! imurain == 1 + ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ENDIF + ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) ) +! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs) + ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) +! ziacrf(mgs) = Min( ziacrf(mgs), z ) + ENDIF + + + + IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) + ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN +! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & +! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) ) + zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & + & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) ) + zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + ENDIF + zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv ) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) ) +! zrfrzf(mgs) = Min( zrfrzf(mgs), z ) + ! change this to be alpha=0? + ENDIF + + IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) + + ENDIF + + IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN + tmp = qx(mgs,ls)/cx(mgs,ls) + r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles + IF ( imusnow == 3 ) THEN + zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + ELSE + write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow + STOP + ENDIF + ENDIF + + IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + tmp = qx(mgs,li)/cx(mgs,li) + r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles + zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + ENDIF + + + pzhwi(mgs) = & + & +ifrzg*ffrzh*(zrfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & +! : + zhcnsh(mgs) + zhcnih(mgs) & + & + zhacw(mgs) & + & + zhacr(mgs) & + & + zhcnhl(mgs) & + & + zhacs(mgs) & + & + zhaci(mgs) & + & + f2h*zhcni(mgs) + f2h*zhcns(mgs) & + & + Max( 0.0, zhdsv(mgs) ) + + pzhwd(mgs) = 0.0 & + & + (1-il5(mgs))*zhmlr(mgs) & + & + zhshr(mgs) & + & + Min( 0.0, zhdsv(mgs) ) & + & - il5(mgs)*zhlcnh(mgs) + + + IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN +! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real +! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) +! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) +! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) + ENDIF + + +! IF ( zhcnhl(mgs) < 0.0 ) THEN +! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) +! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp +! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) +! +!! STOP +! ENDIF + end do + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' + + ENDIF + +! +! Hail reflectivity +! + + do mgs = 1,ngscnt + + zhldsv(mgs) = 0.0 + zhlacr(mgs) = 0.0 + zhlacw(mgs) = 0.0 + + ENDDO + + IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity' + + do mgs = 1,ngscnt + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = Max( alphamin, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) + ENDIF + + zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN + IF ( temg(mgs) >= tfr ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) ) + ! IF ( zhlshrr(mgs) > 0.0 ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? + ENDIF + zhlshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? +! zhlshrr(mgs) = Max( z1, zhlshrr(mgs)) + ELSE + zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ENDIF + + zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) ) + ENDIF + + IF ( zhlshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) + write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + STOP + ENDIF +! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) + +! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) + + qtmp = qhldpv(mgs) + qhlcev(mgs) + ctmp = chldpv(mgs) + chlcev(mgs) + + zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhlacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) + zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) +! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv +! ELSE +! zhlacr(mgs) = 0.0 +! ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + + IF ( qhlacw(mgs) .gt. 0.0 ) THEN + alp = Max( 3.0, alpha(mgs,lhl)+1. ) + g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ENDIF + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + ENDIF + + ELSE ! } .false. { + + IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + IF ( z > zx(mgs,lhl) ) THEN + zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + ENDIF +! qsplinter(mgs) + + IF ( lzhl > 1 ) THEN + pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & + & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & + & + il5(mgs)*zhlcnh(mgs) & + & + zhlacw(mgs) & + & + zhlacr(mgs) & +! : + zhlacs(mgs) & + & + Max( 0.0, zhldsv(mgs) ) + + pzhld(mgs) = 0.0 & + & + (1-il5(mgs))*zhlmlr(mgs) & + & + zhlshr(mgs) & + & - zhcnhl(mgs) & + & + Min( 0.0, zhldsv(mgs) ) + + + IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN + write(iunit,*) 'Problem with pzhli!' + write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs) + ENDIF + + IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN + write(iunit,*) 'Problem with pzhld!' + write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs) + ENDIF + + ENDIF ! lzhl > 1 + + end do + + ENDIF + +! +! rain reflectivity +! + if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11' + + IF ( lzr .gt. 1 ) THEN ! + + DO mgs = 1,ngscnt + + zracw(mgs) = 0.0 + zracr(mgs) = 0.0 + zrcev(mgs) = 0.0 + zrach(mgs) = 0.0 + zrachl(mgs) = 0.0 + zsshr(mgs) = 0.0 + zsshrr(mgs) = 0.0 +! zsmlr(mgs) = 0.0 + zsmlrr(mgs) = 0.0 + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & + csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{ + tmp = qx(mgs,ls)/cx(mgs,ls) + g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2) + IF ( .not. mixedphase ) THEN +! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) + + IF ( csmlrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) ) + zsmlrr(mgs) = z1 + ENDIF + ENDIF + +! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) ) + + IF ( csshrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) ) + zsshrr(mgs) = z1 + ENDIF + + ENDIF !} + + IF ( .not. mixedphase ) THEN !{ + IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{ + tmp = qx(mgs,lh)/cx(mgs,lh) +! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) ) + +! IF ( zhmlrr(mgs) >= 0. ) THEN +! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs) +! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel + z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ENDIF + zhmlrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) +! zhmlrr(mgs) = Max( z1, zhmlrr(mgs)) + ENDIF !} + + +! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs) + + IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) +! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) ) + +! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation +! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs) +! ENDIF + + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ENDIF + zhlmlrr(mgs) = z1 + +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs)) +! zhlmlr(mgs) = +! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs) + ENDIF + + ENDIF ! } + + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN + + tmp = qx(mgs,lr)/cx(mgs,lr) + g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + + IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) + ENDIF + + IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ENDIF + + qtmp = qrcev(mgs) + ctmp = crcev(mgs) + +! IF ( .false. .or. iferwisventr == 2 ) THEN +! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) ) +! ELSE + zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + + IF ( iferwisventr == 2 ) THEN + vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) + zrcev(mgs) = Max( zrcev(mgs), vent1 ) + ENDIF +! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN +! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr) +! ENDIF + + +! ENDIF + zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) + + IF ( qhacr(mgs) > 0.0 ) THEN + zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) ) + + ENDIF + + IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN + zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) ) + zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) ) + ENDIF - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & - & +qhlacr(mgs)+qhlacw(mgs) & -! & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & -qhlmul1(mgs) - qhcnhl(mgs) - end do + + ENDIF - ENDIF ! lhl + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + & + Max( 0.,zrcev(mgs) ) & + & - (1-il5(mgs))*zsmlrr(mgs) & + & - zsshrr(mgs) & + & - (1-il5(mgs))*zhmlrr(mgs) & + & - zhshrr(mgs) & + & - (1-il5(mgs))*zhlmlrr(mgs) & + & - zhlshrr(mgs) - ENDIF ! warmonly -! -! Liquid water on snow and graupel -! + pzrwd(mgs) = 0.0 & + & + Min(0.,zrcev(mgs) ) & + & - zrach(mgs) & + & - zrachl(mgs) & + & - zrfrz(mgs) & + & - il5(mgs)*(ziacr(mgs) ) - vhmlr(:) = 0.0 - vhlmlr(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 - IF ( mixedphase ) THEN - ELSE ! set arrays for non-mixedphase graupel - -! vhshdr(:) = 0.0 - vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation -! vhsoak(:) = 0.0 + IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & + .and. qx(mgs,lr) > qxmin(lr) ) THEN + pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs) + ENDIF -! vhlshdr(:) = 0.0 - vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) -! vhlsoak(:) = 0.0 + ENDDO - ENDIF ! mixedphase + ENDIF @@ -18390,6 +22528,33 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & + & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lh) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lh) + ENDIF + ELSE + dnmx = xdnmx(lh) + ENDIF + + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) ) + + drhodt = (xdn_new - xdn(mgs,lh))*dtpinv + + zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt + + pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs)) + pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs)) + + + ENDIF IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -18472,6 +22637,32 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & + & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lhl) + ENDIF + ELSE + dnmx = xdnmx(lhl) + ENDIF + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) ) + + drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv + + zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt + + pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs)) + pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs)) + + + ENDIF ENDDO @@ -18701,7 +22892,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) - write(iunit,*) (qssbv(mgs)) + write(iunit,*) qssbv(mgs) write(iunit,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) ! @@ -18773,33 +22964,37 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & (qhmlr(mgs)+ & + & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & & +il5(mgs)*(1-imixedphase)*( & & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & & +qsshr(mgs) & & +qhshr(mgs) & - & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qiacr(mgs) & & ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + & (qhmlr(mgs)+qsmlr(mgs)+ & + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & - & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & + qssbv(mgs) + qhsbv(mgs) & + & + qhlsbv(mgs) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & - & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) & + + Min(0.0,qfcev(mgs)) ! NOTE: pdep is the deposition part only pdep(mgs) = & & il5(mgs)*( & @@ -18827,7 +23022,7 @@ subroutine nssl_2mom_gs & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 @@ -18855,6 +23050,8 @@ subroutine nssl_2mom_gs & ! ! do mgs = 1,ngscnt + + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & @@ -18867,6 +23064,7 @@ subroutine nssl_2mom_gs & & dtp*(pqswi(mgs)+pqswd(mgs)) qx(mgs,lh) = qx(mgs,lh) + & & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) @@ -18936,12 +23134,32 @@ subroutine nssl_2mom_gs & + ENDIF + ENDIF + IF ( ipconc .ge. 6 ) THEN + IF ( lzr .gt. 1 ) THEN + zx(mgs,lr) = zx(mgs,lr) + & + & dtp*(pzrwi(mgs)+pzrwd(mgs)) + ENDIF + IF ( lzs .gt. 1 ) THEN + zx(mgs,ls) = zx(mgs,ls) + & + & dtp*(pzswi(mgs)+pzswd(mgs)) + ENDIF + IF ( lzh .gt. 1 ) THEN + zx(mgs,lh) = zx(mgs,lh) + & + & dtp*(pzhwi(mgs)+pzhwd(mgs)) + ENDIF + IF ( lzhl .gt. 1 ) THEN + zx(mgs,lhl) = zx(mgs,lhl) + & + & dtp*(pzhli(mgs)+pzhld(mgs)) +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF ENDIF ENDIF end do end if - IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) @@ -19183,41 +23401,9 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN -! C$PAR CRITICAL SECTION -! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), -! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), -! : ltemq,igs(mgs),jy,kgs(mgs) -! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), -! : ab(igs(mgs),jy,kgs(mgs),lt), -! : t0(igs(mgs),jy,kgs(mgs)) -! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) -! STOP -! C$PAR END CRITICAL SECTION -! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) qis(mgs) = pqs(mgs)*tabqis(ltemq) -! qss(kz) = qvs(kz) -! if ( temg(kz) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) -! qss(kz) = qis(kz) -! end if -! dont get enough condensation with qcw .le./.gt. qxmin(lc) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if qss(mgs) = qvs(mgs) if ( temg(mgs) .lt. tfr ) then if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & @@ -19456,7 +23642,6 @@ subroutine nssl_2mom_gs & - if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -19487,6 +23672,29 @@ subroutine nssl_2mom_gs & ENDIF + + + +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il)) + lfsave(mgs,4) = zx(mgs,il) + ENDIF + + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il)) + + ENDIF + ENDDO + + ENDIF ! end do ! @@ -19551,11 +23759,466 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs + ELSE ! } { is three-moment, so have to adjust Z if size is too large + IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN + +! rdmx = +! rdmn = + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN + tmp = cx(mgs,il) +! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.) +! STOP + IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + + + ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL + + + + DO mgs = 1,ngscnt + + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il)) + lfsave(mgs,6) = cx(mgs,il) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + IF ( cx(mgs,lhl) > cxmin ) THEN + frac = chxf(mgs,lhl)/cx(mgs,lhl) + ELSE + frac = 0.0 + ENDIF + ENDIF + + IF ( il == lh .and. lnhf > 1 ) THEN + IF ( cx(mgs,lh) > cxmin ) THEN + frach = chxf(mgs,lh)/cx(mgs,lh) + ELSE + frach = 0.0 + ENDIF + ENDIF + + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSE + IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + zx(mgs,il) = 0.0 + ENDIF + ENDIF !} + + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{ + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{ +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + +! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + +! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + ELSE + ! have all valid moments, so find shape parameter + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN !{ + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{ + tmp = cx(mgs,il) + + + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF !} + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{ + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + +! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! z = z1*(6./(pi*xdn(mgs,il)))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + + ENDIF !} + + ENDIF !} + + + ENDIF ! !} + + + + ENDIF !} + + IF ( lzr > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) + ENDIF + IF ( lzh > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) )) + ENDIF + IF ( lzhl > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) )) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lhl) = frac*cx(mgs,lhl) + ENDIF + IF ( il == lh .and. lnhf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lh) = frach*cx(mgs,lh) + ENDIF + + +! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN +! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) +! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) +! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs) +! +! ENDIF + + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + + +! CALL cld_cpu('Z-DELABK') + + + + + ENDIF ! } } + ENDIF ! }} ENDIF ! } DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + IF ( il == lhl ) THEN IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops diff --git a/phys/module_mp_wsm6.F b/phys/module_mp_wsm6.F index 3812b4282d..d0d45e69a2 100644 --- a/phys/module_mp_wsm6.F +++ b/phys/module_mp_wsm6.F @@ -1,2682 +1,240 @@ -#if ( (defined(wrfmodel) ) && ( RWORDSIZE == 4 ) ) || ( ( defined(mpas) ) && defined(SINGLE_PRECISION) ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm6 -! - USE module_mp_radar - USE module_model_constants, only : RE_QC_BG, RE_QI_BG, RE_QS_BG -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain -! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow -! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow -! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur - REAL, SAVE :: & - qc0, qck1, pidnc, & - bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc,pi, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,refl_10cm, diagflag, do_radar_ref & - ,graupel, graupelncv & - ,has_reqc, has_reqi, has_reqs & ! for radiation - ,re_cloud, re_ice, re_snow & ! for radiation - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & -#if ( WRF_CHEM == 1) - ,wetscav_on, evapprod, rainprod & -#endif - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - qg - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr -! for radiation connecting - INTEGER, INTENT(IN):: & - has_reqc, & - has_reqi, & - has_reqs - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - INTENT(INOUT):: & - re_cloud, & - re_ice, & - re_snow -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, & ! GT - INTENT(INOUT) :: refl_10cm -!+---+-----------------------------------------------------------------+ + module module_mp_wsm6 + use ccpp_kind_types,only: kind_phys - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv + use mp_wsm6,only: mp_wsm6_run + use mp_wsm6_effectrad,only: mp_wsm6_effectRad_run -#if ( WRF_CHEM == 1 ) - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(INOUT) :: & - rainprod, & - evapprod - LOGICAL, INTENT(IN) :: wetscav_on - -! local variable - REAL, DIMENSION( its:ite , kts:kte ) :: & - rainprod2d, & - evapprod2d -#endif - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs - INTEGER :: i,j,k -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(kts:kte):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ - LOGICAL, OPTIONAL, INTENT(IN) :: diagflag - INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref -!+---+-----------------------------------------------------------------+ -! to calculate effective radius for radiation - REAL, DIMENSION( kts:kte ) :: den1d - REAL, DIMENSION( kts:kte ) :: qc1d - REAL, DIMENSION( kts:kte ) :: qi1d - REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs + implicit none + private + public:: wsm6 - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - qrs(i,k,3) = qg(i,k,j) - ENDDO - ENDDO - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - CALL wsm62D(t, q(ims,kms,j), qci, qrs & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & -#if ( WRF_CHEM == 1) - ,wetscav_on, rainprod2d, evapprod2d & -#endif - ) - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - qg(i,k,j) = qrs(i,k,3) - ENDDO - ENDDO -!+---+-----------------------------------------------------------------+ - IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then - DO I=its,ite - DO K=kts,kte - t1d(k)=th(i,k,j)*pii(i,k,j) - p1d(k)=p(i,k,j) - qv1d(k)=q(i,k,j) - qr1d(k)=qr(i,k,j) - qs1d(k)=qs(i,k,j) - qg1d(k)=qg(i,k,j) - ENDDO - call refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, i, j) - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - ENDDO - endif - ENDIF + contains - if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then - do i=its,ite - do k=kts,kte - re_qc(k) = RE_QC_BG - re_qi(k) = RE_QI_BG - re_qs(k) = RE_QS_BG - t1d(k) = th(i,k,j)*pii(i,k,j) - den1d(k)= den(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qs1d(k) = qs(i,k,j) - enddo - call effectRad_wsm6(t1d, qc1d, qi1d, qs1d, den1d, & - qmin, t0c, re_qc, re_qi, re_qs, & - kts, kte, i, j) - do k=kts,kte - re_cloud(i,k,j) = MAX(RE_QC_BG, MIN(re_qc(k), 50.E-6)) - re_ice(i,k,j) = MAX(RE_QI_BG, MIN(re_qi(k), 125.E-6)) - re_snow(i,k,j) = MAX(RE_QS_BG, MIN(re_qs(k), 999.E-6)) - enddo - enddo - endif ! has_reqc, etc... -!+---+-----------------------------------------------------------------+ -#if( WRF_CHEM == 1 ) - if( wetscav_on ) then - do i=its,ite - do k=kts,kte - rainprod(i,k,j) = rainprod2d(i,k) - evapprod(i,k,j) = evapprod2d(i,k) - enddo - enddo - endif -#endif - ENDDO - END SUBROUTINE wsm6 -!=================================================================== -! - SUBROUTINE wsm62D(t, q & - ,qci, qrs, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & -#if ( WRF_CHEM == 1 ) - ,wetscav_on, rainprod2d, evapprod2d & +!================================================================================================================= + subroutine wsm6(th,q,qc,qr,qi,qs,qg,den,pii,p,delz, & + delt,g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin, & + xls,xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,snow,snowncv,graupel,graupelncv,sr, & + refl_10cm,diagflag,do_radar_ref, & + has_reqc,has_reqi,has_reqs, & + re_qc_bg,re_qi_bg,re_qs_bg, & + re_qc_max,re_qi_max,re_qs_max, & + re_cloud,re_ice,re_snow, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + errmsg,errflg & +#if(WRF_CHEM == 1) + ,wetscav_on,evapprod,rainprod & #endif - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! further modifications : -! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 -! ==> higher accuracy and efficient at lower resolutions -! reflectivity computation from greg thompson, lim, jun 2011 -! ==> only diagnostic, but with removal of too large drops -! add hail option from afwa, aug 2014 -! ==> switch graupel or hail by changing no, den, fall vel. -! effective radius of hydrometeors, bae from kiaps, jan 2015 -! ==> consistency in solar insolation of rrtmg radiation -! bug fix in melting terms, bae from kiaps, nov 2015 -! ==> density of air is divided, which has not been -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! Juang and Hong (JH, 2010) Mon. Wea. Rev. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv - -#if ( WRF_CHEM == 1) - REAL, DIMENSION( its:ite , kts:kte ), INTENT(INOUT) :: & - rainprod2d, & - evapprod2d - LOGICAL, INTENT(IN) :: wetscav_on + ) +!================================================================================================================= + +!--- input arguments: + logical,intent(in),optional:: diagflag + + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: has_reqc,has_reqi,has_reqs + integer,intent(in),optional:: do_radar_ref + + real(kind=kind_phys),intent(in):: & + delt,g,rd,rv,t0c,den0,cpd,cpv,ep1,ep2,qmin,xls,xlv0,xlf0, & + cliq,cice,psat,denr + + real(kind=kind_phys),intent(in):: & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme ):: & + den, & + pii, & + p, & + delz + +!inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + rain,rainncv,sr + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + snow,snowncv + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + graupel,graupelncv + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + re_cloud, & + re_ice, & + re_snow + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + refl_10cm + +#if(WRF_CHEM == 1) + logical,intent(in):: wetscav_on + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme ):: & + rainprod,evapprod + real(kind=kind_phys),dimension(its:ite,kts:kte):: rainprod_hv,evapprod_hv #endif -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - qrs_tmp, & - falk, & - fall, & - work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - fallc, & - falkc, & - work1c, & - work2c, & - workr, & - worka - REAL, DIMENSION( its:ite , kts:kte ) :: & - den_tmp, & - delz_tmp - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - REAL, DIMENSION( its:ite , kts:kte ) :: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - denqrs1, & - denqrs2, & - denqrs3, & - denqci, & - n0sfac - REAL, DIMENSION( its:ite ) :: delqrs1, & - delqrs2, & - delqrs3, & - delqi - REAL, DIMENSION( its:ite ) :: tstepsnow, & - tstepgraup - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: & - cpmcal, xlcal, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n, idim, kdim -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! Optimizatin : A**B => exp(log(A)*(B)) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - idim = ite-its+1 - kdim = kte-kts+1 -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo - do k = kts, kte - do i = its, ite - delz_tmp(i,k) = delz(i,k) - den_tmp(i,k) = den(i,k) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the surface rain, snow, graupel -! - do i = its, ite - rainncv(i) = 0. - if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i,lat) = 0. - if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i,lat) = 0. - sr(i) = 0. -! new local array to catch step snow and graupel - tstepsnow(i) = 0. - tstepgraup(i) = 0. - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - do k = kts, kte - do i = its, ite - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!---------------------------------------------------------------- - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - workr(i,k) = work1(i,k,1) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - ELSE - worka(i,k) = 0. - ENDIF - denqrs1(i,k) = den(i,k)*qrs(i,k,1) - denqrs2(i,k) = den(i,k)*qrs(i,k,2) - denqrs3(i,k) = den(i,k)*qrs(i,k,3) - if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & - delqrs1,dtcld,1,1) - call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & - denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) - do k = kts, kte - do i = its, ite - qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) - qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) - qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) - fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) - fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) - fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) - enddo - enddo - do i = its, ite - fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld - fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld - fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld - enddo - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/den(i,k) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/den(i,k) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work1c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - endif - enddo - enddo -! -! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) -! - do k = kte, kts, -1 - do i = its, ite - denqci(i,k) = den(i,k)*qci(i,k,2) - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & - delqi,dtcld,1,0) - do k = kts, kte - do i = its, ite - qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) - enddo - enddo - do i = its, ite - fallc(i,1) = delqi(i)/delz(i,1)/dtcld - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - if(fallsum_qsi.gt.0.) then - tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +tstepsnow(i) - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +snowncv(i,lat) - snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat) - ENDIF - endif - if(fallsum_qg.gt.0.) then - tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - +tstepgraup(i) - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - graupelncv(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + graupelncv(i,lat) - graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat) - ENDIF - endif - IF ( PRESENT (snowncv)) THEN - if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12) - ELSE - if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) - ENDIF - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! *rslope(i,k,1)*dtcld,qrs(i,k,1)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! update the slope parameters for microphysics computation -! - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -!------------------------------------------------------------------ -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*qci(i,k,1)**(7./3.) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - +diameter**2*rslope(i,k,1) - praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. - ! reduce collection efficiency (suggested by B. Wilt) - praci(i,k) = praci(i,k)*min(max(0.0,qrs(i,k,1)/qci(i,k,2)),1.)**2 - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - *rslopeb(i,k,1)/24./den(i,k) - ! reduce collection efficiency (suggested by B. Wilt) - piacr(i,k) = piacr(i,k)*min(max(0.0,qci(i,k,2)/qrs(i,k,1)),1.)**2 - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - +diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,2)/qci(i,k,1)),1.)**2 & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,3)/qci(i,k,1)),1.)**2 & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qsum(i,k) .gt. 1.e-15) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - ! reduce collection efficiency (suggested by B. Wilt) - pracs(i,k) = pracs(i,k)*min(max(0.0,qrs(i,k,1)/qrs(i,k,2)),1.)**2 - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - ! reduce collection efficiency (suggested by B. Wilt) - psacr(i,k) = psacr(i,k)*min(max(0.0,qrs(i,k,2)/qrs(i,k,1)),1.)**2 - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - ! reduce collection efficiency (suggested by B. Wilt) - pgacr(i,k) = pgacr(i,k)*min(max(0.0,qrs(i,k,3)/qrs(i,k,1)),1.)**2 - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - /xlf,-qrs(i,k,3)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - *rslope2(i,k,2)+precs2*work2(i,k) & - *coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - +pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - *delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - +psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - -#if( WRF_CHEM == 1 ) - if( wetscav_on ) then - rainprod2d = praut+pracw+praci+psaci+pgaci+psacw+pgacw+paacw+psaut - evapprod2d = -(prevp+psevp+pgevp+psdep+pgdep) - endif -#endif - - END SUBROUTINE wsm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,hail_opt,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - INTEGER, INTENT(IN) :: hail_opt ! RAS - LOGICAL, INTENT(IN) :: allowed_to_read - -! RAS13.1 define graupel parameters as graupel-like or hail-like, -! depending on namelist option - IF (hail_opt .eq. 1) THEN !Hail! - n0g = 4.e4 - deng = 700. - avtg = 285.0 - bvtg = 0.8 - lamdagmax = 2.e4 - ELSE !Graupel! - n0g = 4.e6 - deng = 500 - avtg = 330.0 - bvtg = 0.8 - lamdagmax = 6.e4 - ENDIF -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. ! syb -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax - -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - xam_r = PI*denr/6. - xbm_r = 3. - xmu_r = 0. - xam_s = PI*dens/6. - xbm_s = 3. - xmu_s = 0. - xam_g = PI*deng/6. - xbm_g = 3. - xmu_g = 0. - - call radar_init -!+---+-----------------------------------------------------------------+ - -! - END SUBROUTINE wsm6init -!------------------------------------------------------------------------------ - subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte,3) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt - REAL, DIMENSION( its:ite , kts:kte) :: & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, lamdas, lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) - vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) - vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) - if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 - if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 - if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 - enddo - enddo - END subroutine slope_wsm6 -!----------------------------------------------------------------------------- - subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtr - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_rain -!------------------------------------------------------------------------------ - subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdas, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = rslope(i,k)**bvts - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_snow -!---------------------------------------------------------------------------------- - subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopegmax - rslopeb(i,k) = rslopegbmax - rslope2(i,k) = rslopeg2max - rslope3(i,k) = rslopeg3max - else - rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtg - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_graup -!--------------------------------------------------------------------------------- -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),precip(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - enddo - qa(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - rql(i,:) = qn(:) -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter,ist - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 - precip1(:) = 0.0 - precip2(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - qq2(:) = rql2(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) + qq2(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qa2(k) = qq2(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - qr2(k) = qa2(k)/den(k) - enddo - qa(km+1) = 0.0 - qa2(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) - do k = 1, km - tmp(k) = max((qr(k)+qr2(k)), 1.E-15) - IF ( tmp(k) .gt. 1.e-15 ) THEN - wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) - ELSE - wa(k) = 0. - ENDIF - enddo - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & -! ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif - ist_loop : do ist = 1, 2 - if (ist.eq.2) then - qa(:) = qa2(:) - endif -! - precip(i) = 0. -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - if(ist.eq.1) then - rql(i,:) = qn(:) - precip1(i) = precip(i) - else - rql2(i,:) = qn(:) - precip2(i) = precip(i) - endif - enddo ist_loop -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm6 - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii, jj) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg - REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti - - DOUBLE PRECISION:: cback, x, eta, f_d - REAL, PARAMETER:: R=287. - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = min(n0smax, n0s*exp(-alpha*temp_C)) - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo +!local variables and arrays: + logical:: do_microp_re + integer:: i,j,k + real(kind=kind_phys),dimension(kts:kte):: qv1d,t1d,p1d,qr1d,qs1d,qg1d,dBZ + real(kind=kind_phys),dimension(kts:kte):: den1d,qc1d,qi1d,re_qc,re_qi,re_qs -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ + real(kind=kind_phys),dimension(its:ite):: rainncv_hv,rain_hv,sr_hv + real(kind=kind_phys),dimension(its:ite):: snowncv_hv,snow_hv + real(kind=kind_phys),dimension(its:ite):: graupelncv_hv,graupel_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: t_hv,den_hv,p_hv,delz_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,qr_hv,qs_hv,qg_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: re_qc_hv,re_qi_hv,re_qs_hv - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 +!----------------------------------------------------------------------------------------------------------------- -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif + do j = jts,jte + do i = its,ite + !input arguments: + do k = kts,kte + den_hv(i,k) = den(i,k,j) + p_hv(i,k) = p(i,k,j) + delz_hv(i,k) = delz(i,k,j) enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_wsm6 -!+---+-----------------------------------------------------------------+ -!----------------------------------------------------------------------- - subroutine effectRad_wsm6 (t, qc, qi, qs, rho, qmin, t0c, & - re_qc, re_qi, re_qs, kts, kte, ii, jj) - -!----------------------------------------------------------------------- -! Compute radiation effective radii of cloud water, ice, and snow for -! single-moment microphysics. -! These are entirely consistent with microphysics assumptions, not -! constant or otherwise ad hoc as is internal to most radiation -! schemes. -! Coded and implemented by Soo ya Bae, KIAPS, January 2015. -!----------------------------------------------------------------------- + !inout arguments: + rain_hv(i) = rain(i,j) + + do k = kts,kte + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + qv_hv(i,k) = q(i,k,j) + qc_hv(i,k) = qc(i,k,j) + qi_hv(i,k) = qi(i,k,j) + qr_hv(i,k) = qr(i,k,j) + qs_hv(i,k) = qs(i,k,j) + qg_hv(i,k) = qg(i,k,j) + enddo + enddo - implicit none + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow_hv(i) = snow(i,j) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel_hv(i) = graupel(i,j) + enddo + endif + +!--- call to cloud microphysics scheme: + call mp_wsm6_run(t=t_hv,q=qv_hv,qc=qc_hv,qi=qi_hv,qr=qr_hv,qs=qs_hv,qg=qg_hv, & + den=den_hv,p=p_hv,delz=delz_hv,delt=delt,g=g,cpd=cpd,cpv=cpv, & + rd=rd,rv=rv,t0c=t0c,ep1=ep1,ep2=ep2,qmin=qmin,xls=xls,xlv0=xlv0, & + xlf0=xlf0,den0=den0,denr=denr,cliq=cliq,cice=cice,psat=psat, & + rain=rain_hv,rainncv=rainncv_hv,sr=sr_hv,snow=snow_hv, & + snowncv=snowncv_hv,graupel=graupel_hv,graupelncv=graupelncv_hv, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg & +#if(WRF_CHEM == 1) + ,rainprod2d=rainprod_hv,evapprod2d=evapprod_hv & +#endif + ) + + do i = its,ite + !inout arguments: + rain(i,j) = rain_hv(i) + rainncv(i,j) = rainncv_hv(i) + sr(i,j) = sr_hv(i) + + do k = kts,kte + th(i,k,j) = t_hv(i,k)/pii(i,k,j) + q(i,k,j) = qv_hv(i,k) + qc(i,k,j) = qc_hv(i,k) + qi(i,k,j) = qi_hv(i,k) + qr(i,k,j) = qr_hv(i,k) + qs(i,k,j) = qs_hv(i,k) + qg(i,k,j) = qg_hv(i,k) + enddo + enddo -!..Sub arguments - integer, intent(in) :: kts, kte, ii, jj - real, intent(in) :: qmin - real, intent(in) :: t0c - real, dimension( kts:kte ), intent(in):: t - real, dimension( kts:kte ), intent(in):: qc - real, dimension( kts:kte ), intent(in):: qi - real, dimension( kts:kte ), intent(in):: qs - real, dimension( kts:kte ), intent(in):: rho - real, dimension( kts:kte ), intent(inout):: re_qc - real, dimension( kts:kte ), intent(inout):: re_qi - real, dimension( kts:kte ), intent(inout):: re_qs -!..Local variables - integer:: i,k - integer :: inu_c - real, dimension( kts:kte ):: ni - real, dimension( kts:kte ):: rqc - real, dimension( kts:kte ):: rqi - real, dimension( kts:kte ):: rni - real, dimension( kts:kte ):: rqs - real :: temp - real :: lamdac - real :: supcol, n0sfac, lamdas - real :: diai ! diameter of ice in m - logical :: has_qc, has_qi, has_qs -!..Minimum microphys values - real, parameter :: R1 = 1.E-12 - real, parameter :: R2 = 1.E-6 -!..Mass power law relations: mass = am*D**bm - real, parameter :: bm_r = 3.0 - real, parameter :: obmr = 1.0/bm_r - real, parameter :: nc0 = 3.E8 -!----------------------------------------------------------------------- - has_qc = .false. - has_qi = .false. - has_qs = .false. + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow(i,j) = snow_hv(i) + snowncv(i,j) = snowncv_hv(i) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel(i,j) = graupel_hv(i) + graupelncv(i,j) = graupelncv_hv(i) + enddo + endif + +#if(WRF_CHEM == 1) + if(wetscav_on) then + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = rainprod_hv(i,k) + evapprod(i,k,j) = evapprod_hv(i,k) + enddo + enddo + else + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = 0. + evapprod(i,k,j) = 0. + enddo + enddo + endif +#endif - do k = kts, kte - ! for cloud - rqc(k) = max(R1, qc(k)*rho(k)) - if (rqc(k).gt.R1) has_qc = .true. - ! for ice - rqi(k) = max(R1, qi(k)*rho(k)) - temp = (rho(k)*max(qi(k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - ni(k) = min(max(5.38e7*temp,1.e3),1.e6) - rni(k)= max(R2, ni(k)*rho(k)) - if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. - ! for snow - rqs(k) = max(R1, qs(k)*rho(k)) - if (rqs(k).gt.R1) has_qs = .true. - enddo +!--- call to computation of effective radii for cloud water, cloud ice, and snow: + do_microp_re = .false. + if(has_reqc == 1 .and. has_reqi == 1 .and. has_reqs == 1) do_microp_re = .true. - if (has_qc) then - do k=kts,kte - if (rqc(k).le.R1) CYCLE - lamdac = (pidnc*nc0/rqc(k))**obmr - re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + do k = kts,kte + do i = its,ite + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + re_qc_hv(i,k) = re_cloud(i,k,j) + re_qi_hv(i,k) = re_ice(i,k,j) + re_qs_hv(i,k) = re_snow(i,k,j) enddo - endif + enddo - if (has_qi) then - do k=kts,kte - if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE - diai = 11.9*sqrt(rqi(k)/ni(k)) - re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) - enddo - endif + call mp_wsm6_effectRad_run(do_microp_re,t_hv,qc_hv,qi_hv,qs_hv,den_hv,qmin,t0c, & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max,re_qc_hv, & + re_qi_hv,re_qs_hv,its,ite,kts,kte,errmsg,errflg) - if (has_qs) then - do k=kts,kte - if (rqs(k).le.R1) CYCLE - supcol = t0c-t(k) - n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) - lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) - re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + do k = kts,kte + do i = its,ite + re_cloud(i,k,j) = re_qc_hv(i,k) + re_ice(i,k,j) = re_qi_hv(i,k) + re_snow(i,k,j) = re_qs_hv(i,k) enddo - endif + enddo + + enddo - end subroutine effectRad_wsm6 -!----------------------------------------------------------------------- + end subroutine wsm6 -END MODULE module_mp_wsm6 +!================================================================================================================= + end module module_mp_wsm6 +!================================================================================================================= diff --git a/phys/module_pbl_driver.F b/phys/module_pbl_driver.F index 7807f7a98c..9b643f739d 100644 --- a/phys/module_pbl_driver.F +++ b/phys/module_pbl_driver.F @@ -28,6 +28,7 @@ SUBROUTINE pbl_driver( & ,kpbl,mixht,ct,lh,snow,xice & ,znu, znw, mut, p_top & ,ctopo,ctopo2,windfarm_opt,power & + ,windfarm_wake_model, windfarm_overlap_method & ,ysu_topdown_pblmix & ,shinhong_tke_diag & ! OPTIONAL for TEMF scheme @@ -39,7 +40,7 @@ SUBROUTINE pbl_driver( & ,flhc,flqc & ! MYNN ,qke,Sh3d,Sm3d & - ,qke_adv,bl_mynn_tkeadvect & !ACF for QKE advection + ,qke_adv,bl_mynn_tkeadvect & ,tsq,qsq,cov,rmol,ch,qcg,grav_settling & ,dqke,qWT,qSHEAR,qBUOY,qDISS,tke_budget & ,bl_mynn_closure,bl_mynn_cloudpdf & @@ -158,6 +159,7 @@ SUBROUTINE pbl_driver( & CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, & FITCHSCHEME,SHINHONGSCHEME, & TEMFPBLSCHEME,GBMPBLSCHEME,EEPSSCHEME,KEPSSCHEME, & + MAVSCHEME, & ! Yulong add for WLM CAMMGMPSCHEME,p_qi,p_qni,p_qnc,param_first_scalar,& !CAMMGMPSCHEME, p_qni,p_qnc is used for camuwpbl scheme p_qnwfa,p_qnifa,p_qnbca #if ( WRFPLUS == 1 ) @@ -170,6 +172,7 @@ SUBROUTINE pbl_driver( & , TEMFPBLSCHEME, GFSEDMFSCHEME & , CAMUWPBLSCHEME & , FITCHSCHEME, SHINHONGSCHEME & + , MAVSCHEME ! Yulong add for WLM , GBMPBLSCHEME, MYJSFCSCHEME #endif @@ -201,6 +204,7 @@ SUBROUTINE pbl_driver( & USE module_bl_keps USE module_bl_fogdes USE module_wind_fitch + USE module_wind_mav ! Yulong add for WLM #endif use module_ra_gfdleta, only: cal_mon_day @@ -438,6 +442,9 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN), OPTIONAL :: xlat_u,xlong_u,xlat_v,xlong_v + ! Yulong add for WLM + INTEGER, INTENT(IN ) :: windfarm_wake_model, windfarm_overlap_method + REAL, DIMENSION( ims:ime, kms:kme ,jms:jme ), & INTENT(IN), OPTIONAL :: w ! @@ -829,6 +836,7 @@ SUBROUTINE pbl_driver( & integer iu_bep,iurb,idiff real seamask,thsk,zzz,unew,vnew,tnew,qnew,umom,vmom REAL :: z0,z1,z2,w1,w2 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: TKE_windfarm ! Yulong add for WLM INTEGER :: ihour, jmonth, jday ! ! FASDAS @@ -839,6 +847,10 @@ SUBROUTINE pbl_driver( & ! ! END FASDAS ! +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg +! !------------------------------------------------------------------ ! !!!!!!!if using BEP set flag_bep to true @@ -1203,13 +1215,13 @@ SUBROUTINE pbl_driver( & PRESENT( hol ) ) THEN ! CALL ysu( & - U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy & + U3D=u_phytmp,V3D=v_phytmp,T3D=t_phy & ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr & ,P3D=p_phy,P3DI=p8w,PI3D=pi_phy & ,RUBLTEN=rublten,RVBLTEN=rvblten & ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten & ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & - ,FLAG_QI=flag_qi & + ,FLAG_QI=flag_qi,FLAG_QC=flag_qc & ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg & ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC & ,ZNT=znt,UST=ust,HPBL=pblh & @@ -1222,7 +1234,7 @@ SUBROUTINE pbl_driver( & ,YSU_TOPDOWN_PBLMIX=ysu_topdown_pblmix & ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl & ,EP1=ep_1,EP2=ep_2,KARMAN=karman & - ,EXCH_H=exch_h,EXCH_M=exch_m,REGIME=regime & + ,EXCH_H=exch_h,EXCH_M=exch_m & ,RTHRATEN=RTHRATEN & ! for multilayer UCM ,IDIFF=idiff,FLAG_BEP=flag_bep,FRC_URB2D=frc_urb2d & @@ -1234,6 +1246,7 @@ SUBROUTINE pbl_driver( & ,DL_U_BEP=dl_u_bep,SF_BEP=sf_bep,VL_BEP=vl_bep & ! for grims shallow convection with ysupbl ,WSTAR=wstar,DELTA=delta & + ,errmsg=errmsg,errflg=errflg & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & @@ -2072,6 +2085,47 @@ SUBROUTINE pbl_driver( & CALL wrf_error_fatal('Lack arguments to call turbine_drag') ENDIF + ! Yulong add new wind farm schemes with wind turbine loss effect + CASE (mavscheme) + IF (PRESENT(id) .AND. & + PRESENT(z_at_w) ) THEN + CALL wrf_debug(100,'in phys/module_wind_mav.F') + CALL dragforce_mav(itimestep & + &,ID=id & + &,Z_AT_W=z_at_w,z_at_m=z,u=u_phy,v=v_phy & + &,DX=dx,DZ=dz8w,DT=dt & + &,TKE=TKE_windfarm & + &,DU=rublten,DV=rvblten & + &,WINDFARM_OPT=windfarm_opt,POWER=power & + &,windfarm_wake_model=windfarm_wake_model & + &,windfarm_overlap_method=windfarm_overlap_method & + &,xland=xland & + &,cosa=cosa,sina=sina & + &,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + &,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + &,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + &) + + IF (bl_mynn_tkeadvect) THEN + QKE = QKE + 2.*TKE_windfarm + qke_adv=qke + ENDIF + + ELSE + WRITE ( message , FMT = '(A,6(L1,1X))' ) & + 'present: '// & + 'ID, '// & + 'z_at_w, '// & + 'xlat_u, '// & + 'xlong_u, '// & + 'xlat_v, '// & + 'xlong_v = ' , & + PRESENT( id ) , & + PRESENT( z_at_w ) + CALL wrf_debug(0,message) + CALL wrf_error_fatal('Lack arguments to call dragforce_mav') + ENDIF + END SELECT windfarm_select #endif @@ -2093,7 +2147,8 @@ SUBROUTINE pbl_driver( & ,ZNU=znu,ZNW=znw,P_TOP=p_top & ,CP=cp,G=g,RD=r_d & ,RV=r_v,EP1=ep_1,PI=3.141592653 & - ,DT=dtbl,DX=dx,KPBL2D=kpbl,ITIMESTEP=itimestep & + ,DT=dtbl,DX=dx2d,KPBL2D=kpbl,ITIMESTEP=itimestep & + ,errmsg=errmsg,errflg=errflg & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte ) diff --git a/phys/module_physics_init.F b/phys/module_physics_init.F index 9e1c641368..cb741d0719 100644 --- a/phys/module_physics_init.F +++ b/phys/module_physics_init.F @@ -233,15 +233,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & t00, p00, tlp, & !for obs-nudging TYR,TYRA,TDLY,TLAG,NYEAR,NDAY,tmn_update, & ACHFX,ACLHF,ACGRDFLX, & - nssl_cccn, & - nssl_alphah,nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & -! next 2 flags for Explicit lightning: - nssl_ipelec, & - nssl_isaund, & ! OPTIONAL RQCNCUTEN, RQINCUTEN, & rliq, & !BSINGH:01/31/2013 - Added rliq and is_CAMMGMP_used for CAM5 physics @@ -293,6 +284,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & USE module_cam_support, ONLY : cam_mam_aerosols #endif USE module_wind_fitch + USE module_wind_mav ! Yulong add for WLM IMPLICIT NONE !----------------------------------------------------------------- TYPE (grid_config_rec_type) :: config_flags @@ -825,13 +817,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & TYPE(fdob_type), OPTIONAL, INTENT(INOUT) :: fdob #endif REAL, OPTIONAL, INTENT(IN) :: p00, t00, tlp ! for obs-nudging base-state calcn - REAL, INTENT(IN) :: nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs - - INTEGER, INTENT(IN) :: nssl_ipelec,nssl_isaund ! WA 12/21/09 REAL,OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & @@ -1019,9 +1004,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & (config_flags%ra_sw_physics .eq. goddardswscheme ) ) .and. & (config_flags%mp_physics .eq. THOMPSON .or. & config_flags%mp_physics .eq. THOMPSONAERO .or. & - config_flags%mp_physics .eq. NSSL_2MOM .or. & - config_flags%mp_physics .eq. NSSL_2MOMG .or. & - config_flags%mp_physics .eq. NSSL_2MOMCCN .or. & + (config_flags%mp_physics .eq. NSSL_2MOM .and. config_flags%nssl_2moment_on == 1) .or. & config_flags%mp_physics .eq. WSM3SCHEME .or. & config_flags%mp_physics .eq. WSM5SCHEME .or. & config_flags%mp_physics .eq. WSM6SCHEME .or. & @@ -1412,6 +1395,10 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & ! IF ( config_flags%windfarm_opt .EQ. 1 ) THEN CALL init_module_wind_fitch(id,config_flags,xlong,xlat,windfarm_initialized,ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) + ! --- Yulong --- + ELSEIF ( config_flags%windfarm_opt .EQ. 2 ) THEN + CALL init_module_wind_mav(id,config_flags,xlong,xlat,windfarm_initialized, & + dx,ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) ENDIF CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to ra_init' ) @@ -1657,12 +1644,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & allowed_to_read, start_of_simulation, & !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ipelec, nssl_isaund, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & ccn_conc, & ! RAS z_at_q, inv_dens, qnwfa2d, qnbca2d, & ! G. Thompson frc_urb2d, scalar, num_sc, & ! G. Thompson @@ -2641,7 +2622,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ) !Optional oml !-------------------------------------------------------------------- USE module_sf_sfclay - USE module_sf_sfclayrev + USE sf_sfclayrev USE module_sf_slab USE module_sf_pxsfclay USE module_bl_ysu @@ -3108,6 +3089,10 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & INTEGER,OPTIONAL,INTENT(OUT), DIMENSION( ims:ime,jms:jme):: irr_rand_field INTEGER,OPTIONAL :: irr_ph,irr_freq +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + #if ( EM_CORE == 1 ) !local mynn INTEGER :: mynn_closure_level @@ -3156,11 +3141,14 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CALL sfclayinit( allowed_to_read ) isfc = 1 CASE (SFCLAYREVSCHEME) - CALL sfclayrevinit(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) + CALL sf_sfclayrev_init(errmsg,errflg) + IF ( shalwater_z0 .EQ. 1 ) THEN + CALL shalwater_init(ims,ime,jms,jme, & + its,ite,jts,jte, & + bathymetry_flag, shalwater_z0, & + shalwater_depth, water_depth, & + xland,LakeModel,lake_depth,lakemask ) + END IF isfc = 1 CASE (PXSFCSCHEME) CALL pxsfclayinit( allowed_to_read ) @@ -3710,14 +3698,6 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CASE (YSUSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) - CALL ysuinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - RQCBLTEN,RQIBLTEN,P_QI, & - PARAM_FIRST_SCALAR, & - restart, & - allowed_to_read , & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) CASE (SHINHONGSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) @@ -4391,12 +4371,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, allowed_to_read, start_of_simulation, & !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ipelec, nssl_isaund, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & ccn_conc, & ! RAS z_at_q, inv_dens, qnwfa2d, qnbca2d, & ! G. Thompson frc_urb2d, scalar, num_sc, & ! G. Thompson @@ -4406,7 +4380,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, !------------------------------------------------------------------ USE module_mp_wsm3 USE module_mp_wsm5 - USE module_mp_wsm6 + USE mp_wsm6 USE module_mp_wsm7 USE module_mp_etanew USE module_mp_fer_hires @@ -4426,7 +4400,9 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, USE module_mp_wdm5 USE module_mp_wdm6 USE module_mp_wdm7 +#if (WRFPLUS != 1) & !defined( VAR4D ) USE module_mp_nssl_2mom, only: nssl_2mom_init +#endif #if (EM_CORE==1) USE module_mp_cammgmp_driver, ONLY:CAMMGMP_INIT !CAM5's microphysics USE module_mp_morr_two_moment_aero !TWG2017 @@ -4440,12 +4416,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, LOGICAL , INTENT(IN) :: restart LOGICAL , INTENT(OUT) :: warm_rain,adv_moist_cond REAL , INTENT(IN) :: MPDT, DT, DX, DY - REAL, INTENT(IN), OPTIONAL :: nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs - INTEGER, INTENT(IN), OPTIONAL :: nssl_ipelec, nssl_isaund LOGICAL , INTENT(IN) :: start_of_simulation INTEGER , INTENT(IN) :: ixcldliq, ixcldice, ixnumliq, ixnumice ! CAMMGMP specific variables @@ -4477,9 +4447,14 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ! Local INTEGER :: i, j, itf, jtf REAL, DIMENSION(20) :: nssl_params - INTEGER :: nssl_ipelec_tmp + INTEGER :: nssl_ipelec_tmp, nssl_ipconc + logical :: nssl_density_on INTEGER :: i_err +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + warm_rain = .false. adv_moist_cond = .true. itf=min0(ite,ide-1) @@ -4495,33 +4470,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ENDDO ENDIF - IF ( present( nssl_cccn ) ) THEN - SELECT CASE(config_flags%mp_physics) - CASE (NSSL_2MOM,NSSL_2MOMCCN) - IF ( config_flags%elec_physics > 0 ) THEN - nssl_ipelec_tmp = nssl_ipelec - ELSE - nssl_ipelec_tmp = 0.0 - ENDIF - CASE DEFAULT - nssl_ipelec_tmp = 0.0 - END SELECT - - nssl_params(1) = nssl_cccn - nssl_params(2) = nssl_alphah - nssl_params(3) = nssl_alphahl - nssl_params(4) = nssl_cnoh - nssl_params(5) = nssl_cnohl - nssl_params(6) = nssl_cnor - nssl_params(7) = nssl_cnos - nssl_params(8) = nssl_rho_qh - nssl_params(9) = nssl_rho_qhl - nssl_params(10) = nssl_rho_qs - nssl_params(11) = nssl_ipelec_tmp - nssl_params(12) = nssl_isaund - - ENDIF - mp_select: SELECT CASE(config_flags%mp_physics) CASE (KESSLERSCHEME) @@ -4535,7 +4483,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, CASE (WSM5SCHEME) CALL wsm5init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) CASE (WSM6SCHEME) - CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv, config_flags%hail_opt,allowed_to_read ) + CALL mp_wsm6_init(rhoair0,rhowater,rhosnow,cliq,cpv,config_flags%hail_opt,errmsg,errflg) CASE (WSM7SCHEME) CALL wsm7init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) CASE (ETAMPNEW) @@ -4654,17 +4602,53 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, END IF # endif #endif - CASE (NSSL_1MOMLFO) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=-1) ! no separate hail - CASE (NSSL_1MOM) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=0) CASE (NSSL_2MOM) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) - CASE (NSSL_2MOMG) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=-1) ! turn off hail - CASE (NSSL_2MOMCCN) - ccn_conc = nssl_cccn/1.225 ! set this to have correct boundary conditions - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) +! Single generalized case (mp_physics=18) replaces previously separate mp_physics values of 17,18,19,20,22 +#if (WRFPLUS != 1) & !defined( VAR4D ) + + IF ( config_flags%elec_physics > 0 ) THEN + nssl_ipelec_tmp = config_flags%nssl_ipelec + ELSE + nssl_ipelec_tmp = 0.0 + ENDIF + + nssl_params(:) = 0 + nssl_params(1) = config_flags%nssl_cccn + nssl_params(2) = config_flags%nssl_alphah + nssl_params(3) = config_flags%nssl_alphahl + nssl_params(4) = config_flags%nssl_cnoh + nssl_params(5) = config_flags%nssl_cnohl + nssl_params(6) = config_flags%nssl_cnor + nssl_params(7) = config_flags%nssl_cnos + nssl_params(8) = config_flags%nssl_rho_qh + nssl_params(9) = config_flags%nssl_rho_qhl + nssl_params(10) = config_flags%nssl_rho_qs + nssl_params(11) = nssl_ipelec_tmp + nssl_params(12) = config_flags%nssl_isaund + nssl_params(13) = 0 ! reserved + nssl_params(14) = 0 ! reserved + nssl_params(15) = 0 ! reserved + + IF ( config_flags%nssl_2moment_on == 0 ) THEN + nssl_ipconc = 0 + ELSE + IF ( config_flags%nssl_3moment > 0 ) THEN + nssl_ipconc = 8 + ELSE + nssl_ipconc = 5 + ENDIF + ENDIF + + IF ( config_flags % nssl_ccn_on > 0 ) THEN + ccn_conc = config_flags%nssl_cccn/1.225 ! set this to have correct boundary conditions + ENDIF + CALL nssl_2mom_init(nssl_params=nssl_params,ipctmp=nssl_ipconc,mixphase=0, & + nssl_density_on=(config_flags%nssl_density_on > 0), & + nssl_hail_on=config_flags%nssl_hail_on > 0, & + nssl_ccn_on=(config_flags%nssl_ccn_on > 0), & + nssl_icdx=config_flags%nssl_icdx, & + nssl_icdxhl=config_flags%nssl_icdxhl,ccn_is_ccna=config_flags%nssl_ccn_is_ccna) +#endif #if (EM_CORE==1) CASE (CAMMGMPSCHEME) ! CAM5's microphysics CALL CAMMGMP_INIT(ixcldliq, ixcldice, ixnumliq, ixnumice & @@ -5678,4 +5662,61 @@ subroutine compute_2d_dx_area(dx, dy, msftx, msfty, dx2d, area2d, & end subroutine compute_2d_dx_area + SUBROUTINE shalwater_init(ims,ime,jms,jme, & + its,ite,jts,jte, & + bathymetry_flag, shalwater_z0, & + shalwater_depth, water_depth, & + xland,LakeModel,lake_depth,lakemask ) + + INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte + INTEGER, INTENT(IN) :: shalwater_z0 + REAL, INTENT(IN) :: shalwater_depth + INTEGER, INTENT(IN) :: bathymetry_flag + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland + INTEGER :: LakeModel + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth + REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask + + ! Local + LOGICAL :: overwrite_water_depth + overwrite_water_depth = .False. + + IF ( bathymetry_flag .eq. 1 ) THEN + IF ( shalwater_depth .LE. 0.0 ) THEN + IF ( LakeModel .ge. 1 ) THEN + + DO j = jts,jte + DO i = its,ite + IF ( lakemask(i,j) .EQ. 1 ) THEN + water_depth(i,j) = lake_depth(i,j) + END IF + END DO + END DO + END IF + ELSE + overwrite_water_depth = .True. + END IF + ELSE + IF ( shalwater_depth .GT. 0.0 ) THEN + overwrite_water_depth = .True. + ELSE + CALL wrf_error_fatal('No bathymetry data detected and shalwater_depth not greater than 0.0. Re-run WPS to get bathymetry data or set shalwater_depth > 0.0') + END IF + END IF + + IF (overwrite_water_depth) THEN + DO j = jts,jte + DO i = its,ite + IF((XLAND(i,j)-1.5).GE.0)THEN + water_depth(i,j) = shalwater_depth + ELSE + water_depth(i,j) = -2.0 + END IF + END DO + END DO + END IF + + END SUBROUTINE shalwater_init + END MODULE module_physics_init diff --git a/phys/module_ra_rrtmg_lw.F b/phys/module_ra_rrtmg_lw.F index eb8023bc40..6b5dc2d342 100644 --- a/phys/module_ra_rrtmg_lw.F +++ b/phys/module_ra_rrtmg_lw.F @@ -2537,6 +2537,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! todo - need to permute this loop after adding vectorized expf() function do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -3280,6 +3281,7 @@ subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & icldlyr(lay) = 0 ! Change to band loop? +! todo permute, remove condition, vectorize expf do ig = 1, ngptlw if (cldfmc(ig,lay) .eq. 1._rb) then ib = ngb(ig) diff --git a/phys/module_ra_rrtmg_sw.F b/phys/module_ra_rrtmg_sw.F index c0eb328a4d..1149bf8c28 100644 --- a/phys/module_ra_rrtmg_sw.F +++ b/phys/module_ra_rrtmg_sw.F @@ -1845,6 +1845,7 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! permute this loop do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -8597,28 +8598,36 @@ subroutine spcvmc_sw & zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk) ! /\/\/\ Above code only needed for direct beam calculation + enddo - +! to vectorize the following loop + do jk=1, klev ! Delta scaling - clear zf = zgcc(jk) * zgcc(jk) zwf = zomcc(jk) * zf ztauc(jk) = (1.0_rb - zwf) * ztauc(jk) zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf) zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf) + enddo ! Total sky optical parameters (cloud properties already delta-scaled) ! Use this code if cloud properties are derived in rrtmg_sw_cldprop if (icpr .ge. 1) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw) zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk) zomco(jk) = zomco(jk) / ztauo(jk) + enddo ! Total sky optical parameters (if cloud properties not delta scaled) ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop elseif (icpr .eq. 0) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw) zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + & ztaur(ikl,iw) * 1.0_rb @@ -8633,10 +8642,10 @@ subroutine spcvmc_sw & ztauo(jk) = (1._rb - zwf) * ztauo(jk) zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf) zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf) + enddo endif ! End of layer loop - enddo ! Clear sky reflectivities call reftra_sw (klev, & @@ -8734,22 +8743,27 @@ subroutine spcvmc_sw & pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw) pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + enddo ! Accumulate direct fluxes for UV/visible bands if (ibm >= 10 .and. ibm <= 13) then + do jk=1,klev+1 + ikl=klev+2-jk puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw) puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw) puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) + enddo ! Accumulate direct fluxes for near-IR bands else if (ibm == 14 .or. ibm <= 9) then + do jk=1,klev+1 + ikl=klev+2-jk pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw) pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw) pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) - endif - enddo + endif ! End loop on jg, g-point interval enddo @@ -9429,8 +9443,8 @@ subroutine rrtmg_sw & ! enddo ! enddo - do i = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do i = 1, nlayers ztaua(i,ib) = 0._rb zasya(i,ib) = 0._rb zomga(i,ib) = 0._rb @@ -9453,8 +9467,8 @@ subroutine rrtmg_sw & ! IAER=10: Direct specification of aerosol optical properties from GCM elseif (iaer.eq.10) then - do i = 1 ,nlayers - do ib = 1 ,nbndsw + do ib = 1 ,nbndsw + do i = 1 ,nlayers ztaua(i,ib) = taua(i,ib) ztauacln(i,ib) = 0.0 zasya(i,ib) = asma(i,ib) @@ -9934,8 +9948,8 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, & ! modify to reverse layer indexing here if necessary. if (iaer .ge. 1) then - do l = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do l = 1, nlayers taua(l,ib) = tauaer(iplon,l,ib) ssaa(l,ib) = ssaaer(iplon,l,ib) asma(l,ib) = asmaer(iplon,l,ib) diff --git a/phys/module_radiation_driver.F b/phys/module_radiation_driver.F index c981bf7894..1421cbd34f 100644 --- a/phys/module_radiation_driver.F +++ b/phys/module_radiation_driver.F @@ -1405,8 +1405,8 @@ SUBROUTINE radiation_driver ( & CALL wrf_debug (1, 'in rad driver; use BL clouds') IF (itimestep .NE. 1) THEN DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite CLDFRA(i,k,j)=CLDFRA_BL(i,k,j) ENDDO ENDDO @@ -1414,8 +1414,8 @@ SUBROUTINE radiation_driver ( & ENDIF DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite IF (qc(i,k,j) < 1.E-6 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j) ENDIF diff --git a/phys/module_sf_sfclay.F b/phys/module_sf_sfclay.F index 8cdaaa158c..03072e82a6 100644 --- a/phys/module_sf_sfclay.F +++ b/phys/module_sf_sfclay.F @@ -20,7 +20,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -136,6 +136,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -242,7 +243,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & QSFC(ims,j),LH(ims,j), & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK(ims,j), & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -267,7 +268,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -278,6 +279,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !------------------------------------------------------------------- REAL, PARAMETER :: XKA=2.4E-5 REAL, PARAMETER :: PRT=1. + REAL, PARAMETER :: SALINITY_FACTOR=0.98 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -294,6 +296,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK ! REAL, DIMENSION( ims:ime ) , & @@ -452,7 +455,9 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 60 I=its,ite E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) ! for land points QSFC can come from previous time step - if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) +! the saturation vapor pressure for salty water is on average 2% lower + if(xland(i).gt.1.5 .and. lakemask(i).eq.0.) E1=E1*SALINITY_FACTOR + if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE ! Q2SAT = QGH IN LSM E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) diff --git a/phys/module_sf_sfclayrev.F b/phys/module_sf_sfclayrev.F index 2a3ca5a01d..8f8939a8e1 100644 --- a/phys/module_sf_sfclayrev.F +++ b/phys/module_sf_sfclayrev.F @@ -1,1373 +1,319 @@ -!WRF:MODEL_LAYER:PHYSICS -! -MODULE module_sf_sfclayrev - - REAL , PARAMETER :: VCONVC=1. - REAL , PARAMETER :: CZO=0.0185 - REAL , PARAMETER :: OZO=1.59E-5 - - REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab,psih_stab,psih_unstab - -CONTAINS - -!------------------------------------------------------------------- - SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w, & - CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM, & - ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, & - FM,FH, & - XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & - U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000mb, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! Changes in V3.7 over water surfaces: -! 1. for ZNT/Cd, replacing constant OZO with 0.11*1.5E-5/UST(I) -! the COARE 3.5 (Edson et al. 2013) formulation is also available -! 2. for VCONV, reducing magnitude by half -! 3. for Ck, replacing Carlson-Boland with COARE 3 -!------------------------------------------------------------------- -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- T3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -!-- P3D 3D pressure (Pa) -!-- dz8w dz between full levels (m) -!-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- G acceleration due to gravity (m/s^2) -!-- ROVCP R/CP -!-- R gas constant for dry air (J/kg/K) -!-- XLV latent heat of vaporization for water (J/kg) -!-- PSFC surface pressure (Pa) -!-- ZNT roughness length (m) -!-- UST u* in similarity theory (m/s) -!-- USTM u* in similarity theory (m/s) without vconv correction -! used to couple with TKE scheme -!-- PBLH PBL height from previous time (m) -!-- MAVAIL surface moisture availability (between 0 and 1) -!-- ZOL z/L height over Monin-Obukhov length -!-- MOL T* (similarity theory) (K) -!-- REGIME flag indicating PBL regime (stable, unstable, etc.) -!-- PSIM similarity stability function for momentum -!-- PSIH similarity stability function for heat -!-- FM integrated stability function for momentum -!-- FH integrated stability function for heat -!-- XLAND land mask (1 for land, 2 for water) -!-- HFX upward heat flux at the surface (W/m^2) -!-- QFX upward moisture flux at the surface (kg/m^2/s) -!-- LH net upward latent heat flux at surface (W/m^2) -!-- TSK surface temperature (K) -!-- FLHC exchange coefficient for heat (W/m^2/K) -!-- FLQC exchange coefficient for moisture (kg/m^2/s) -!-- CHS heat/moisture exchange coefficient for LSM (m/s) -!-- QGH lowest-level saturated mixing ratio -!-- QSFC ground saturated mixing ratio -!-- U10 diagnostic 10m u wind -!-- V10 diagnostic 10m v wind -!-- TH2 diagnostic 2m theta (K) -!-- T2 diagnostic 2m temperature (K) -!-- Q2 diagnostic 2m mixing ratio (kg/kg) -!-- GZ1OZ0 log(z/z0) where z0 is roughness length -!-- WSPD wind speed at lowest model level (m/s) -!-- BR bulk Richardson number in surface layer -!-- ISFFLX isfflx=1 for surface heat and moisture fluxes -!-- DX horizontal grid size (m) -!-- SVP1 constant for saturation vapor pressure (kPa) -!-- SVP2 constant for saturation vapor pressure (dimensionless) -!-- SVP3 constant for saturation vapor pressure (K) -!-- SVPT0 constant for saturation vapor pressure (K) -!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) -!-- EP2 constant for specific humidity calculation -! (R_d/R_v) (dimensionless) -!-- KARMAN Von Karman constant -!-- EOMEG angular velocity of earth's rotation (rad/s) -!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) -!-- ck enthalpy exchange coeff at 10 meters -!-- cd momentum exchange coeff at 10 meters -!-- cka enthalpy exchange coeff at the lowest model level -!-- cda momentum exchange coeff at the lowest model level -!-- isftcflx =0, (Charnock and Carlson-Boland); =1, AHW Ck, Cd, =2 Garratt -!-- iz0tlnd =0 Carlson-Boland, =1 Czil_new -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- its start index for i in tile -!-- ite end index for i in tile -!-- jts start index for j in tile -!-- jte end index for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte -! - INTEGER, INTENT(IN ) :: ISFFLX - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT - REAL, INTENT(IN ) :: P1000mb -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: dz8w - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: QV3D, & - P3D, & - T3D - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT ) :: U10, & - V10, & - TH2, & - T2, & - Q2 - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - LH, & - QSFC, & - MOL,RMOL -!m the following 5 are change to memory size -! - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & - PSIM,PSIH,FM,FH - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: U3D, & - V3D - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: PSFC - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ZNT, & - ZOL, & - UST, & - CPM, & - CHS2, & - CQS2, & - CHS - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: FLHC,FLQC - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: & - QGH - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: USTM - - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - - INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: water_depth -! LOCAL VARS - - REAL, DIMENSION( its:ite ) :: U1D, & - V1D, & - QV1D, & - P1D, & - T1D - - REAL, DIMENSION( its:ite ) :: dz8w1d - - INTEGER :: I,J - - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,1,j) - ENDDO - - DO i=its,ite - U1D(i) =U3D(i,1,j) - V1D(i) =V3D(i,1,j) - QV1D(i)=QV3D(i,1,j) - P1D(i) =P3D(i,1,j) - T1D(i) =T3D(i,1,j) - ENDDO - - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - - CALL SFCLAYREV1D(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & - CP,G,ROVCP,R,XLV,PSFC(ims,j),CHS(ims,j),CHS2(ims,j),& - CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j), & - ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j), & - MOL(ims,j),REGIME(ims,j),PSIM(ims,j),PSIH(ims,j), & - FM(ims,j),FH(ims,j), & - XLAND(ims,j),HFX(ims,j),QFX(ims,j),TSK(ims,j), & - U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), & - Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j), & - QSFC(ims,j),LH(ims,j), & - GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & - P1000mb, & - shalwater_z0,water_depth(ims,j),shalwater_depth, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & -#if ( EM_CORE == 1 ) - ,isftcflx,iz0tlnd,scm_force_flux, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j) & +!================================================================================================================= + module module_sf_sfclayrev + use ccpp_kind_types,only: kind_phys + use sf_sfclayrev,only: sf_sfclayrev_run + + + implicit none + private + public:: sfclayrev + + + contains + + +!================================================================================================================= + subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & + cp,g,rovcp,r,xlv,psfc,chs,chs2,cqs2,cpm, & + znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & + fm,fh, & + xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & + u10,v10,th2,t2,q2, & + gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,p1000mb,lakemask, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: isfflx + integer,intent(in):: shalwater_z0 + integer,intent(in),optional:: isftcflx, iz0tlnd + integer,intent(in),optional:: scm_force_flux + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=kind_phys),intent(in):: ep1,ep2,karman + real(kind=kind_phys),intent(in):: p1000mb + real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + mavail, & + pblh, & + psfc, & + tsk, & + xland, & + lakemask, & + water_depth + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + qv3d, & + p3d, & + t3d, & + u3d, & + v3d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + regime, & + hfx, & + qfx, & + qsfc, & + mol, & + rmol, & + gz1oz0, & + wspd, & + br, & + psim, & + psih, & + fm, & + fh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + flhc, & + flqc, & + qgh + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + ustm + +!--- local variables and arrays: + logical:: l_isfflx + logical:: l_shalwater_z0 + logical:: l_scm_force_flux + + integer:: i,j,k + real(kind=kind_phys),dimension(its:ite):: dz1d,u1d,v1d,qv1d,p1d,t1d + + real(kind=kind_phys),dimension(its:ite):: & + dx_hv,mavail_hv,pblh_hv,psfc_hv,tsk_hv,xland_hv,water_depth_hv,lakemask_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + dz_hv,u_hv,v_hv,qv_hv,p_hv,t_hv + + real(kind=kind_phys),dimension(its:ite):: & + lh_hv,u10_hv,v10_hv,th2_hv,t2_hv,q2_hv + real(kind=kind_phys),dimension(its:ite):: & + ck_hv,cka_hv,cd_hv,cda_hv + + real(kind=kind_phys),dimension(its:ite):: & + regime_hv,hfx_hv,qfx_hv,qsfc_hv,mol_hv,rmol_hv,gz1oz0_hv,wspd_hv, & + br_hv,psim_hv,psih_hv,fm_hv,fh_hv,znt_hv,zol_hv,ust_hv,cpm_hv, & + chs2_hv,cqs2_hv,chs_hv,flhc_hv,flqc_hv,qgh_hv + real(kind=kind_phys),dimension(its:ite):: & + ustm_hv + +!----------------------------------------------------------------------------------------------------------------- + + l_isfflx = .false. + l_shalwater_z0 = .false. + l_scm_force_flux = .false. + if(isfflx .eq. 1) l_isfflx = .true. + if(shalwater_z0 .eq. 1) l_shalwater_z0 = .true. + if(scm_force_flux .eq. 1) l_scm_force_flux = .true. + + do j = jts,jte + + do i = its,ite + !input arguments: + dx_hv(i) = dx(i,j) + mavail_hv(i) = mavail(i,j) + pblh_hv(i) = pblh(i,j) + psfc_hv(i) = psfc(i,j) + tsk_hv(i) = tsk(i,j) + xland_hv(i) = xland(i,j) + lakemask_hv(i) = lakemask(i,j) + water_depth_hv(i) = water_depth(i,j) + + do k = kts,kte + dz_hv(i,k) = dz8w(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + p_hv(i,k) = p3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + enddo + + !inout arguments: + regime_hv(i) = regime(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + qsfc_hv(i) = qsfc(i,j) + mol_hv(i) = mol(i,j) + rmol_hv(i) = rmol(i,j) + gz1oz0_hv(i) = gz1oz0(i,j) + wspd_hv(i) = wspd(i,j) + br_hv(i) = br(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + fm_hv(i) = fm(i,j) + fh_hv(i) = fh(i,j) + znt_hv(i) = znt(i,j) + zol_hv(i) = zol(i,j) + ust_hv(i) = ust(i,j) + cpm_hv(i) = cpm(i,j) + chs2_hv(i) = chs2(i,j) + cqs2_hv(i) = cqs2(i,j) + chs_hv(i) = chs(i,j) + flhc_hv(i) = flhc(i,j) + flqc_hv(i) = flqc(i,j) + qgh_hv(i) = qgh(i,j) + enddo + + if(present(ustm)) then + do i = its,ite + ustm_hv(i) = ustm(i,j) + enddo + endif + + call sf_sfclayrev_pre_run(dz2d=dz_hv,u2d=u_hv,v2d=v_hv,qv2d=qv_hv,p2d=p_hv,t2d=t_hv, & + dz1d=dz1d,u1d=u1d,v1d=v1d,qv1d=qv1d,p1d=p1d,t1d=t1d, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg) + + call sf_sfclayrev_run(ux=u1d,vx=v1d,t1d=t1d,qv1d=qv1d,p1d=p1d,dz8w1d=dz1d, & + cp=cp,g=g,rovcp=rovcp,r=r,xlv=xlv,psfcpa=psfc_hv,chs=chs_hv, & + chs2=chs2_hv,cqs2=cqs2_hv,cpm=cpm_hv,pblh=pblh_hv, & + rmol=rmol_hv,znt=znt_hv,ust=ust_hv,mavail=mavail_hv, & + zol=zol_hv,mol=mol_hv,regime=regime_hv,psim=psim_hv, & + psih=psih_hv,fm=fm_hv,fh=fh_hv,xland=xland_hv,lakemask=lakemask_hv, & + hfx=hfx_hv,qfx=qfx_hv,tsk=tsk_hv,u10=u10_hv, & + v10=v10_hv,th2=th2_hv,t2=t2_hv,q2=q2_hv,flhc=flhc_hv, & + flqc=flqc_hv,qgh=qgh_hv,qsfc=qsfc_hv,lh=lh_hv, & + gz1oz0=gz1oz0_hv,wspd=wspd_hv,br=br_hv,isfflx=l_isfflx,dx=dx_hv, & + svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,ep1=ep1,ep2=ep2,karman=karman, & + p1000mb=p1000mb,shalwater_z0=l_shalwater_z0,water_depth=water_depth_hv, & + its=its,ite=ite,errmsg=errmsg,errflg=errflg & +#if ( ( EM_CORE == 1 ) || ( defined(mpas) ) ) + ,isftcflx=isftcflx,iz0tlnd=iz0tlnd,scm_force_flux=l_scm_force_flux, & + ustm=ustm_hv,ck=ck_hv,cka=cka_hv,cd=cd_hv,cda=cda_hv & #endif - ) - ENDDO - - - END SUBROUTINE SFCLAYREV - - -!------------------------------------------------------------------- - SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, & - ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,FM,FH,& - XLAND,HFX,QFX,TSK, & - U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH, & - QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000mb, & - shalwater_z0,water_depth,shalwater_depth, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - isftcflx, iz0tlnd,scm_force_flux, & - ustm,ck,cka,cd,cda ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - REAL, PARAMETER :: XKA=2.4E-5 - REAL, PARAMETER :: PRT=1. - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - J -! - INTEGER, INTENT(IN ) :: ISFFLX - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT - REAL, INTENT(IN ) :: P1000mb - -! - REAL, DIMENSION( ims:ime ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK -! - REAL, DIMENSION( ims:ime ) , & - INTENT(IN ) :: PSFCPA - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - MOL,RMOL -!m the following 5 are changed to memory size--- -! - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & - PSIM,PSIH,FM,FH - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: ZNT, & - ZOL, & - UST, & - CPM, & - CHS2, & - CQS2, & - CHS - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: FLHC,FLQC - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: & - QSFC,QGH - - REAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: U10,V10, & - TH2,T2,Q2,LH - - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX - - INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth - REAL, DIMENSION( ims:ime ), INTENT(IN) :: water_depth -! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY - REAL, DIMENSION( its:ite ), INTENT(IN ) :: dz8w1d - - REAL, DIMENSION( its:ite ), INTENT(IN ) :: UX, & - VX, & - QV1D, & - P1D, & - T1D - - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: USTM - - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - -! LOCAL VARS - - REAL, DIMENSION( its:ite ) :: ZA, & - THVX,ZQKL, & - ZQKLP1, & - THX,QX, & - PSIH2, & - PSIM2, & - PSIH10, & - PSIM10, & - DENOMQ, & - DENOMQ2, & - DENOMT2, & - WSPDI, & - GZ2OZ0, & - GZ10OZ0 -! - REAL, DIMENSION( its:ite ) :: & - RHOX,GOVRTH, & - TGDSA -! - REAL, DIMENSION( its:ite) :: SCR3,SCR4 - REAL, DIMENSION( its:ite ) :: THGB, PSFC -! - INTEGER :: KL - - INTEGER :: N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10 - - REAL :: PL,THCON,TVCON,E1 - REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 - REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT - REAL :: ZW, ZN1, ZN2 -! -! .... paj ... -! - REAL :: zolzz,zol0 -! REAL :: zolri,zolri2 -! REAL :: psih_stable,psim_stable,psih_unstable,psim_unstable -! REAL :: psih_stable_full,psim_stable_full,psih_unstable_full,psim_unstable_full - REAL :: zl2,zl10,z0t - REAL, DIMENSION( its:ite ) :: pq,pq2,pq10 - - -!------------------------------------------------------------------- - KL=kte - - DO i=its,ite -! PSFC cb - PSFC(I)=PSFCPA(I)/1000. - ENDDO -! -!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: -! - DO 5 I=its,ite - TGDSA(I)=TSK(I) -! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP - 5 CONTINUE -! -!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., -! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. -! -! *** NOTE *** -! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, -! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE -! TENDENCIES. -! - 10 CONTINUE - -! DO 24 I=its,ite -! UX(I)=U1D(I) -! VX(I)=V1D(I) -! 24 CONTINUE - - 26 CONTINUE - -!.....SCR3(I,K) STORE TEMPERATURE, -! SCR4(I,K) STORE VIRTUAL TEMPERATURE. - - DO 30 I=its,ite -! PL cb - PL=P1D(I)/1000. - SCR3(I)=T1D(I) -! THCON=(100./PL)**ROVCP - THCON=(P1000mb*0.001/PL)**ROVCP - THX(I)=SCR3(I)*THCON - SCR4(I)=SCR3(I) - THVX(I)=THX(I) - QX(I)=0. - 30 CONTINUE -! - DO I=its,ite - QGH(I)=0. - FLHC(I)=0. - FLQC(I)=0. - CPM(I)=CP - ENDDO -! -! IF(IDRY.EQ.1)GOTO 80 - DO 50 I=its,ite - QX(I)=QV1D(I) - TVCON=(1.+EP1*QX(I)) - THVX(I)=THX(I)*TVCON - SCR4(I)=SCR3(I)*TVCON - 50 CONTINUE -! - DO 60 I=its,ite - E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) -! for land points QSFC can come from previous time step - if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) -! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE -! Q2SAT = QGH IN LSM - E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) - PL=P1D(I)/1000. - QGH(I)=EP2*E1/(PL-E1) - CPM(I)=CP*(1.+0.8*QX(I)) - 60 CONTINUE - 80 CONTINUE - -!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND -! LEVEL, AND THE LAYER THICKNESSES. - - DO 90 I=its,ite - ZQKLP1(I)=0. - RHOX(I)=PSFC(I)*1000./(R*SCR4(I)) - 90 CONTINUE -! - DO 110 I=its,ite - ZQKL(I)=dz8w1d(I)+ZQKLP1(I) - 110 CONTINUE -! - DO 120 I=its,ite - ZA(I)=0.5*(ZQKL(I)+ZQKLP1(I)) - 120 CONTINUE -! - DO 160 I=its,ite - GOVRTH(I)=G/THX(I) - 160 CONTINUE - -!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO -! AKB(1976), EQ(12). - - DO 260 I=its,ite - GZ1OZ0(I)=ALOG((ZA(I)+ZNT(I))/ZNT(I)) ! log((z+z0)/z0) - GZ2OZ0(I)=ALOG((2.+ZNT(I))/ZNT(I)) ! log((2+z0)/z0) - GZ10OZ0(I)=ALOG((10.+ZNT(I))/ZNT(I)) ! log((10+z0)z0) - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF - WSPD(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) - - TSKV=THGB(I)*(1.+EP1*QSFC(I)) - DTHVDZ=(THVX(I)-TSKV) -! Convective velocity scale Vc and subgrid-scale velocity Vsg -! following Beljaars (1994, QJRMS) and Mahrt and Sun (1995, MWR) -! ... HONG Aug. 2001 -! -! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! Use Beljaars over land, old MM5 (Wyngaard) formula over water - if (xland(i).lt.1.5) then - fluxc = max(hfx(i)/rhox(i)/cp & - + ep1*tskv*qfx(i)/rhox(i),0.) - VCONV = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 - else - IF(-DTHVDZ.GE.0)THEN - DTHVM=-DTHVDZ - ELSE - DTHVM=0. - ENDIF -! VCONV = 2.*SQRT(DTHVM) -! V3.7: reducing contribution in calm conditions - VCONV = SQRT(DTHVM) - endif -! Mahrt and Sun low-res correction - VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 - WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV+vsgd*vsgd) - WSPD(I)=AMAX1(WSPD(I),0.1) - BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) -! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 - IF(MOL(I).LT.0.)BR(I)=AMIN1(BR(I),0.0) -!jdf - RMOL(I)=-GOVRTH(I)*DTHVDZ*ZA(I)*KARMAN -!jdf - - 260 CONTINUE - -! -!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: -! -! -! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) -! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). -! -! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: -! -! 1. BR .GE. 0.0; -! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), -! -! 3. BR .EQ. 0.0 -! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), -! -! 4. BR .LT. 0.0 -! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). -! -!CCCCC - - DO 320 I=its,ite -! - if (br(I).gt.0) then - if (br(I).gt.250.0) then - zol(I)=zolri(250.0,ZA(I),ZNT(I)) - else - zol(I)=zolri(br(I),ZA(I),ZNT(I)) - endif - endif -! - if (br(I).lt.0) then - IF(UST(I).LT.0.001)THEN - ZOL(I)=BR(I)*GZ1OZ0(I) - ELSE - if (br(I).lt.-250.0) then - zol(I)=zolri(-250.0,ZA(I),ZNT(I)) - else - zol(I)=zolri(br(I),ZA(I),ZNT(I)) - endif - ENDIF - endif -! -! ... paj: compute integrated similarity functions. -! - zolzz=zol(I)*(za(I)+znt(I))/za(I) ! (z+z0/L - zol10=zol(I)*(10.+znt(I))/za(I) ! (10+z0)/L - zol2=zol(I)*(2.+znt(I))/za(I) ! (2+z0)/L - zol0=zol(I)*znt(I)/za(I) ! z0/L - ZL2=(2.)/ZA(I)*ZOL(I) ! 2/L - ZL10=(10.)/ZA(I)*ZOL(I) ! 10/L - - IF((XLAND(I)-1.5).LT.0.)THEN - ZL=(0.01)/ZA(I)*ZOL(I) ! (0.01)/L - ELSE - ZL=ZOL0 ! z0/L - ENDIF - - IF(BR(I).LT.0.)GOTO 310 ! go to unstable regime (class 4) - IF(BR(I).EQ.0.)GOTO 280 ! go to neutral regime (class 3) -! -!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: -! - REGIME(I)=1. -! -! ... paj: psim and psih. Follows Cheng and Brutsaert 2005 (CB05). -! - psim(I)=psim_stable(zolzz)-psim_stable(zol0) - psih(I)=psih_stable(zolzz)-psih_stable(zol0) -! - psim10(I)=psim_stable(zol10)-psim_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) -! - psim2(I)=psim_stable(zol2)-psim_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) -! -! ... paj: preparations to compute PSIQ. Follows CB05+Carlson Boland JAM 1978. -! - pq(I)=psih_stable(zol(I))-psih_stable(zl) - pq2(I)=psih_stable(zl2)-psih_stable(zl) - pq10(I)=psih_stable(zl10)-psih_stable(zl) -! -! 1.0 over Monin-Obukhov length - RMOL(I)=ZOL(I)/ZA(I) -! - - GOTO 320 -! -!-----CLASS 3; FORCED CONVECTION: -! - 280 REGIME(I)=3. - PSIM(I)=0.0 - PSIH(I)=PSIM(I) - PSIM10(I)=0. - PSIH10(I)=PSIM10(I) - PSIM2(I)=0. - PSIH2(I)=PSIM2(I) -! -! paj: preparations to compute PSIQ. -! - pq(I)=PSIH(I) - pq2(I)=PSIH2(I) - pq10(I)=0. -! - ZOL(I)=0. - RMOL(I) = ZOL(I)/ZA(I) - - GOTO 320 -! -!-----CLASS 4; FREE CONVECTION: -! - 310 CONTINUE - REGIME(I)=4. -! -! ... paj: PSIM and PSIH ... -! - psim(I)=psim_unstable(zolzz)-psim_unstable(zol0) - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) -! - psim10(I)=psim_unstable(zol10)-psim_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) -! - psim2(I)=psim_unstable(zol2)-psim_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) -! -! ... paj: preparations to compute PSIQ -! - pq(I)=psih_unstable(zol(I))-psih_unstable(zl) - pq2(I)=psih_unstable(zl2)-psih_unstable(zl) - pq10(I)=psih_unstable(zl10)-psih_unstable(zl) -! -!---LIMIOT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS -!--- THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL - PSIH(I)=AMIN1(PSIH(I),0.9*GZ1OZ0(I)) - PSIM(I)=AMIN1(PSIM(I),0.9*GZ1OZ0(I)) - PSIH2(I)=AMIN1(PSIH2(I),0.9*GZ2OZ0(I)) - PSIM10(I)=AMIN1(PSIM10(I),0.9*GZ10OZ0(I)) -! -! AHW: mods to compute ck, cd - PSIH10(I)=AMIN1(PSIH10(I),0.9*GZ10OZ0(I)) - - RMOL(I) = ZOL(I)/ZA(I) - - 320 CONTINUE -! -!-----COMPUTE THE FRICTIONAL VELOCITY: -! ZA(1982) EQS(2.60),(2.61). -! - DO 330 I=its,ite - DTG=THX(I)-THGB(I) - PSIX=GZ1OZ0(I)-PSIM(I) - PSIX10=GZ10OZ0(I)-PSIM10(I) - -! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL -! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 -! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) - PSIT=GZ1OZ0(I)-PSIH(I) - PSIT2=GZ2OZ0(I)-PSIH2(I) -! - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF -! - PSIQ=ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-pq(I) - PSIQ2=ALOG(KARMAN*UST(I)*2./XKA+2./ZL)-pq2(I) - -! AHW: mods to compute ck, cd - PSIQ10=ALOG(KARMAN*UST(I)*10./XKA+10./ZL)-pq10(I) - -! V3.7: using Fairall 2003 to compute z0q and z0t over water: -! adapted from module_sf_mynn.F - IF ( (XLAND(I)-1.5).GE.0. ) THEN - VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 - RESTAR=UST(I)*ZNT(I)/VISC - Z0T = (5.5e-5)*(RESTAR**(-0.60)) - Z0T = MIN(Z0T,1.0e-4) - Z0T = MAX(Z0T,2.0e-9) - Z0Q = Z0T - -! following paj: - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif - PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I) - - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I) - PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I) - ENDIF - - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.EQ.1 .AND. (XLAND(I)-1.5).GE.0. ) THEN -! v3.1 -! Z0Q = 1.e-4 + 1.e-3*(MAX(0.,UST(I)-1.))**2 -! hfip1 -! Z0Q = 0.62*2.0E-5/UST(I) + 1.E-3*(MAX(0.,UST(I)-1.5))**2 -! v3.2 - Z0Q = 1.e-4 -! -! ... paj: recompute psih for z0q -! - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0Q)-PSIH(I) - PSIT=PSIQ - PSIQ2=ALOG((2.+z0q)/Z0Q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0Q)-PSIH10(I) - PSIT2=PSIQ2 - ENDIF - IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN -! AHW: Garratt formula: Calculate roughness Reynolds number -! Kinematic viscosity of air (linear approc to -! temp dependence at sea level) -! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which -! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 - VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 -!! VISC=1.5E-5 - RESTAR=UST(I)*ZNT(I)/VISC - GZ0OZT=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.71)-5.) -! -! ... paj: compute psih for z0t for temperature ... -! - z0t=znt(I)/exp(GZ0OZT) -! - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! -! PSIT=GZ1OZ0(I)-PSIH(I)+RESTAR2 -! PSIT2=GZ2OZ0(I)-PSIH2(I)+RESTAR2 - PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I) -! - GZ0OZQ=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.60)-5.) - z0q=znt(I)/exp(GZ0OZQ) -! - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I) - PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I) -! PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2. -! PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2. -! PSIQ10=GZ10OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2. - ENDIF - ENDIF - IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN - Ck(I)=(karman/psix10)*(karman/psiq10) - Cd(I)=(karman/psix10)*(karman/psix10) - Cka(I)=(karman/psix)*(karman/psiq) - Cda(I)=(karman/psix)*(karman/psix) - ENDIF - IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND.GE.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN - ZL=ZNT(I) -! CZIL RELATED CHANGES FOR LAND - VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 - RESTAR=UST(I)*ZL/VISC -! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 -! If iz0tlnd = 2, use traditional value - - IF ( IZ0TLND.EQ.1 ) THEN - CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) - ELSE IF ( IZ0TLND.EQ.2 ) THEN - CZIL = 0.1 - END IF -! -! ... paj: compute phish for z0t over land -! - z0t=znt(I)/exp(CZIL*KARMAN*SQRT(RESTAR)) -! - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIQ2=ALOG((2.+z0t)/Z0t)-PSIH2(I) - PSIT=PSIQ - PSIT2=PSIQ2 -! -! PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIT2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIQ2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) - - ENDIF - ENDIF -! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE - UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX -! TKE coupling: compute ust without vconv for use in tke scheme - WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) - IF ( PRESENT(USTM) ) THEN - USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX - ENDIF - - U10(I)=UX(I)*PSIX10/PSIX - V10(I)=VX(I)*PSIX10/PSIX - TH2(I)=THGB(I)+DTG*PSIT2/PSIT - Q2(I)=QSFC(I)+(QX(I)-QSFC(I))*PSIQ2/PSIQ - T2(I) = TH2(I)*(PSFCPA(I)/P1000mb)**ROVCP -! - IF((XLAND(I)-1.5).LT.0.)THEN - UST(I)=AMAX1(UST(I),0.001) - ENDIF - MOL(I)=KARMAN*DTG/PSIT/PRT - DENOMQ(I)=PSIQ - DENOMQ2(I)=PSIQ2 - DENOMT2(I)=PSIT2 - FM(I)=PSIX - FH(I)=PSIT - 330 CONTINUE -! - 335 CONTINUE - -!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: - IF ( PRESENT(SCM_FORCE_FLUX) ) THEN - IF (SCM_FORCE_FLUX.EQ.1) GOTO 350 - ENDIF - DO i=its,ite - QFX(i)=0. - HFX(i)=0. - ENDDO - 350 CONTINUE - - IF (ISFFLX.EQ.0) GOTO 410 - -!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). - - DO 360 I=its,ite - IF((XLAND(I)-1.5).GE.0)THEN -! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO - ! PSH - formulation for depth-dependent roughness from - ! ... Jimenez and Dudhia, 2018 - IF ( shalwater_z0 .eq. 1 ) THEN - ZNT(I) = depth_dependent_z0(water_depth(I),ZNT(I),UST(I)) - ELSE - ! Since V3.7 (ref: EC Physics document for Cy36r1) - ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) - ! V3.9: Add limit as in isftcflx = 1,2 - ZNT(I)=MIN(ZNT(I),2.85e-3) - ENDIF -! COARE 3.5 (Edson et al. 2013) -! CZC = 0.0017*WSPD(I)-0.005 -! CZC = min(CZC,0.028) -! ZNT(I)=CZC*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) -! AHW: change roughness length, and hence the drag coefficients Ck and Cd - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN -! ZNT(I)=10.*exp(-9.*UST(I)**(-.3333)) -! ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333)) -! ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01) -! ZNT(I)=0.011*UST(I)*UST(I)/G+OZO -! ZNT(I)=MAX(ZNT(I),3.50e-5) -! AHW 2012: - ZW = MIN((UST(I)/1.06)**(0.3),1.0) - ZN1 = 0.011*UST(I)*UST(I)/G + OZO - ZN2 = 10.*exp(-9.5*UST(I)**(-.3333)) + & - 0.11*1.5E-5/AMAX1(UST(I),0.01) - ZNT(I)=(1.0-ZW) * ZN1 + ZW * ZN2 - ZNT(I)=MIN(ZNT(I),2.85e-3) - ZNT(I)=MAX(ZNT(I),1.27e-7) - ENDIF - ENDIF - ZL = ZNT(I) - ELSE - ZL = 0.01 - ENDIF - FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/DENOMQ(I) -! FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/( & -! ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-PSIH(I)) - DTTHX=ABS(THX(I)-THGB(I)) - IF(DTTHX.GT.1.E-5)THEN - FLHC(I)=CPM(I)*RHOX(I)*UST(I)*MOL(I)/(THX(I)-THGB(I)) -! write(*,1001)FLHC(I),CPM(I),RHOX(I),UST(I),MOL(I),THX(I),THGB(I),I - 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) - ELSE - FLHC(I)=0. - ENDIF - 360 CONTINUE - -! -!-----COMPUTE SURFACE MOIST FLUX: -! -! IF(IDRY.EQ.1)GOTO 390 -! - IF ( PRESENT(SCM_FORCE_FLUX) ) THEN - IF (SCM_FORCE_FLUX.EQ.1) GOTO 405 - ENDIF - - DO 370 I=its,ite - QFX(I)=FLQC(I)*(QSFC(I)-QX(I)) -! QFX(I)=AMAX1(QFX(I),0.) - LH(I)=XLV*QFX(I) - 370 CONTINUE - -!-----COMPUTE SURFACE HEAT FLUX: -! - 390 CONTINUE - DO 400 I=its,ite - IF(XLAND(I)-1.5.GT.0.)THEN - HFX(I)=FLHC(I)*(THGB(I)-THX(I)) -! IF ( PRESENT(ISFTCFLX) ) THEN -! IF ( ISFTCFLX.NE.0 ) THEN -! AHW: add dissipative heating term (commented out in 3.6.1) -! HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) -! ENDIF -! ENDIF - ELSEIF(XLAND(I)-1.5.LT.0.)THEN - HFX(I)=FLHC(I)*(THGB(I)-THX(I)) -! HFX(I)=AMAX1(HFX(I),-250.) - ENDIF - 400 CONTINUE - - 405 CONTINUE - - DO I=its,ite - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF -!v3.1.1 -! CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & -! /XKA+ZA(I)/ZL)-PSIH(I)) - CHS(I)=UST(I)*KARMAN/DENOMQ(I) -! GZ2OZ0(I)=ALOG(2./ZNT(I)) -! PSIM2(I)=-10.*GZ2OZ0(I) -! PSIM2(I)=AMAX1(PSIM2(I),-10.) -! PSIH2(I)=PSIM2(I) -! v3.1.1 -! CQS2(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*2.0 & -! /XKA+2.0/ZL)-PSIH2(I)) -! CHS2(I)=UST(I)*KARMAN/(GZ2OZ0(I)-PSIH2(I)) - CQS2(I)=UST(I)*KARMAN/DENOMQ2(I) - CHS2(I)=UST(I)*KARMAN/DENOMT2(I) - ENDDO - - 410 CONTINUE -!jdf -! DO I=its,ite -! IF(UST(I).GE.0.1) THEN -! RMOL(I)=RMOL(I)*(-FLHC(I))/(UST(I)*UST(I)*UST(I)) -! ELSE -! RMOL(I)=RMOL(I)*(-FLHC(I))/(0.1*0.1*0.1) -! ENDIF -! ENDDO -!jdf - -! - END SUBROUTINE SFCLAYREV1D - -!==================================================================== - SUBROUTINE sfclayrevinit(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - - INTEGER :: N - REAL :: zolf - - INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte - INTEGER, INTENT(IN) :: shalwater_z0 - REAL, INTENT(IN) :: shalwater_depth - INTEGER, INTENT(IN) :: bathymetry_flag - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland - INTEGER :: LakeModel - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth - REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask - - DO N=0,1000 -! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) - -! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - - ENDDO - IF ( shalwater_z0 .EQ. 1 ) THEN - CALL shalwater_init(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - END IF - - END SUBROUTINE sfclayrevinit - - SUBROUTINE shalwater_init(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - - INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte - INTEGER, INTENT(IN) :: shalwater_z0 - REAL, INTENT(IN) :: shalwater_depth - INTEGER, INTENT(IN) :: bathymetry_flag - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland - INTEGER :: LakeModel - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth - REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask - - ! Local - LOGICAL :: overwrite_water_depth - - overwrite_water_depth = .False. - - IF ( bathymetry_flag .eq. 1 ) THEN - IF ( shalwater_depth .LE. 0.0 ) THEN - IF ( LakeModel .ge. 1 ) THEN - DO j = jts,jte - DO i = its,ite - IF ( lakemask(i,j) .EQ. 1 ) THEN - water_depth(i,j) = lake_depth(i,j) - END IF - END DO - END DO - END IF - ELSE - overwrite_water_depth = .True. - END IF - ELSE - IF ( shalwater_depth .GT. 0.0 ) THEN - overwrite_water_depth = .True. - ELSE - CALL wrf_error_fatal('No bathymetry data detected and shalwater_depth not greater than 0.0. Re-run WPS to get bathymetry data or set shalwater_depth > 0.0') - END IF - END IF - - IF (overwrite_water_depth) THEN - DO j = jts,jte - DO i = its,ite - IF((XLAND(i,j)-1.5).GE.0)THEN - water_depth(i,j) = shalwater_depth - ELSE - water_depth(i,j) = -2.0 - END IF - END DO - END DO - END IF - - END SUBROUTINE shalwater_init - - function zolri(ri,z,z0) -! - if (ri.lt.0.)then - x1=-5. - x2=0. - else - x1=0. - x2=5. - endif -! - fx1=zolri2(x1,ri,z,z0) - fx2=zolri2(x2,ri,z,z0) - iter = 0 - Do While (abs(x1 - x2) > 0.01) - if (iter .eq. 10) return -! check added for potential divide by zero (2019/11) - if(fx1.eq.fx2)return - if(abs(fx2).lt.abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,z,z0) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,z,z0) - zolri=x2 - endif -! - iter = iter + 1 - enddo -! - - return - end function - -! -! ----------------------------------------------------------------------- -! - function zolri2(zol2,ri2,z,z0) -! - if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 -! - zol20=zol2*z0/z ! z0/L - zol3=zol2+zol20 ! (z+z0)/L -! - if (ri2.lt.0) then - psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) - else - psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) - endif -! - zolri2=zol2*psih2/psix2**2-ri2 -! - return - end function -! -! ... integrated similarity functions ... -! - function psim_stable_full(zolf) - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - return - end function - - function psih_stable_full(zolf) - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - return - end function - - function psim_unstable_full(zolf) - x=(1.-16.*zolf)**.25 - psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) -! - ym=(1.-10.*zolf)**0.33 - psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) -! - psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) - - return - end function - - function psih_unstable_full(zolf) - y=(1.-16.*zolf)**.5 - psihk=2.*log((1+y)/2.) -! - yh=(1.-34.*zolf)**0.33 - psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) -! - psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) - - return - end function - -! look-up table functions - function psim_stable(zolf) - integer :: nzol - real :: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - psim_stable = psim_stable_full(zolf) - endif - return - end function - - function psih_stable(zolf) - integer :: nzol - real :: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - psih_stable = psih_stable_full(zolf) - endif - return - end function - - function psim_unstable(zolf) - integer :: nzol - real :: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - psim_unstable = psim_unstable_full(zolf) - endif - return - end function - - function psih_unstable(zolf) - integer :: nzol - real :: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - psih_unstable = psih_unstable_full(zolf) - endif - return - end function - - function depth_dependent_z0(water_depth,z0,UST) - real :: depth_b - real :: effective_depth - IF ( water_depth .lt. 10.0 ) THEN - effective_depth = 10.0 - ELSEIF ( water_depth .gt. 100.0 ) THEN - effective_depth = 100.0 - ELSE - effective_depth = water_depth - ENDIF - - depth_b = 1 / 30.0 * log (1260.0 / effective_depth) - depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) - depth_dependent_z0 = MIN(depth_dependent_z0,0.1) - return - end function -!------------------------------------------------------------------- - -END MODULE module_sf_sfclayrev - -! -! ---------------------------------------------------------- -! - - + ) + + do i = its,ite + !output arguments: + lh(i,j) = lh_hv(i) + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + th2(i,j) = th2_hv(i) + t2(i,j) = t2_hv(i) + q2(i,j) = q2_hv(i) + + !inout arguments: + regime(i,j) = regime_hv(i) + hfx(i,j) = hfx_hv(i) + qfx(i,j) = qfx_hv(i) + qsfc(i,j) = qsfc_hv(i) + mol(i,j) = mol_hv(i) + rmol(i,j) = rmol_hv(i) + gz1oz0(i,j) = gz1oz0_hv(i) + wspd(i,j) = wspd_hv(i) + br(i,j) = br_hv(i) + psim(i,j) = psim_hv(i) + psih(i,j) = psih_hv(i) + fm(i,j) = fm_hv(i) + fh(i,j) = fh_hv(i) + znt(i,j) = znt_hv(i) + zol(i,j) = zol_hv(i) + ust(i,j) = ust_hv(i) + cpm(i,j) = cpm_hv(i) + chs2(i,j) = chs2_hv(i) + cqs2(i,j) = cqs2_hv(i) + chs(i,j) = chs_hv(i) + flhc(i,j) = flhc_hv(i) + flqc(i,j) = flqc_hv(i) + qgh(i,j) = qgh_hv(i) + enddo + + !optional output arguments: + if(present(ck) .and. present(cka) .and. present(cd) .and. present(cda)) then + do i = its,ite + ck(i,j) = ck_hv(i) + cka(i,j) = cka_hv(i) + cd(i,j) = cd_hv(i) + cda(i,j) = cda_hv(i) + enddo + endif + + !optional inout arguments: + if(present(ustm)) then + do i = its,ite + ustm(i,j) = ustm_hv(i) + enddo + endif + + enddo + + end subroutine sfclayrev + +!================================================================================================================= + subroutine sf_sfclayrev_pre_run(dz2d,u2d,v2d,qv2d,p2d,t2d,dz1d,u1d,v1d,qv1d,p1d,t1d, & + its,ite,kts,kte,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + dz2d,u2d,v2d,qv2d,p2d,t2d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz1d,u1d,v1d,qv1d,p1d,t1d + +!--- local variables: + integer:: i + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite + dz1d(i) = dz2d(i,kts) + u1d(i) = u2d(i,kts) + v1d(i) = v2d(i,kts) + qv1d(i) = qv2d(i,kts) + p1d(i) = p2d(i,kts) + t1d(i) = t2d(i,kts) + enddo + + errmsg = 'sf_sfclayrev_timestep_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_pre_run + +!================================================================================================================= + end module module_sf_sfclayrev +!================================================================================================================= diff --git a/phys/module_surface_driver.F b/phys/module_surface_driver.F index ea03855ad9..43dec7c24a 100644 --- a/phys/module_surface_driver.F +++ b/phys/module_surface_driver.F @@ -1469,6 +1469,9 @@ SUBROUTINE surface_driver( & ! WRF-Solar EPS real, dimension (:, :, :), allocatable :: smois_tmp, tslb_tmp +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg ! !------------------------------------------------------------------ ! Initialize local variables @@ -2045,7 +2048,7 @@ SUBROUTINE surface_driver( & u10,v10,th2,t2,q2, & gz1oz0,wspd,br,isfflx,dx2d, & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + P1000mb,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -2063,7 +2066,7 @@ SUBROUTINE surface_driver( & u10,v10,th2,t2,q2, & gz1oz0,wspd,br,isfflx,dx2d, & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + P1000mb,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & @@ -2096,9 +2099,9 @@ SUBROUTINE surface_driver( & znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, & xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & u10,v10,th2,t2,q2, & - gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + gz1oz0,wspd,br,isfflx,dx2d, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & + P1000mb,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -2107,23 +2110,23 @@ SUBROUTINE surface_driver( & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux,sf_surface_physics ) + shalwater_z0,water_depth, & + scm_force_flux,sf_surface_physics,errmsg,errflg ) ELSE CALL SFCLAYREV(u_phytmp,v_phytmp,t_phy,qv_curr,& p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, & znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, & xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & u10,v10,th2,t2,q2, & - gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + gz1oz0,wspd,br,isfflx,dx2d, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & + P1000mb,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) #if ( EM_CORE==1) DO j = j_start(ij),j_end(ij) DO i = i_start(ij),i_end(ij) @@ -5806,10 +5809,10 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FM,FH, & XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & + GZ1OZ0,WSPD,BR,ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,LAKEMASK, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -5818,8 +5821,8 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux,sf_surface_physics ) + shalwater_z0,water_depth, & + scm_force_flux,sf_surface_physics,errmsg,errflg) USE module_sf_sfclayrev implicit none @@ -5830,7 +5833,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, INTENT(IN ) :: ISFFLX REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT + REAL, INTENT(IN ) :: EP1,EP2,KARMAN REAL, INTENT(IN ) :: P1000 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & @@ -5845,6 +5848,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & @@ -5869,7 +5873,8 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & V3D REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: PSFC + INTENT(IN ) :: PSFC, & + DX2D REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ZNT, & @@ -5887,7 +5892,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(INOUT) :: & QGH - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda @@ -5896,7 +5901,6 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN ) :: water_depth INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -5987,11 +5991,15 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & WSPD_SEA, & ZOL_SEA +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + ! INTENT(IN) to SFCLAY; unchanged by the call ! ISFFLX ! SVP1,SVP2,SVP3,SVPT0 - ! EP1,EP2,KARMAN,EOMEG,STBOLT - ! CP,G,ROVCP,R,XLV,DX + ! EP1,EP2,KARMAN + ! CP,G,ROVCP,R,XLV,DX2D ! ISFTCFLX,IZ0TLND ! P1000 ! dz8w @@ -6068,16 +6076,16 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FM,FH, & XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, & U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & + GZ1OZ0,WSPD,BR,ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) ! !Restore land-point values calculated by SSiB (fds 12/2010) IF (itimestep .gt. 1 .and. sf_surface_physics .EQ. 8) then @@ -6162,16 +6170,16 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA, & ! I/O U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea, & ! O GZ1OZ0_SEA,WSPD_SEA,BR_SEA, & ! I/O - ISFFLX,DX, & + ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ! 0 ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd,& - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) ! DO j = JTS , JTE DO i = ITS, ITE @@ -6240,7 +6248,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -6275,6 +6283,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & @@ -6501,7 +6510,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -6595,7 +6604,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ! 0 diff --git a/phys/module_wind_mav.F b/phys/module_wind_mav.F new file mode 100644 index 0000000000..dabb6f1e36 --- /dev/null +++ b/phys/module_wind_mav.F @@ -0,0 +1,2085 @@ +!WRF:MODEL_LAYER:PHYSICS + +MODULE module_wind_mav +! +! Represents kinetic energy extracted by wind turbines and turbulence +! (TKE) they produce at model levels within the rotor area. +! This module is based on module_wind_fitch but uses the Jensen, XA and Gm wake +! loss models instead of the Fitch parameterization + +! Code by Yulong MA (Guangdong-Hong kong-Macau Greater Bay Area Weather +! Research Center for Monitoring Warning and Forecasting;UDEL) and Cristina L. Archer (UDEL) + +! --- NOTICE --- +! The following papers should be cited whenever presenting results using this scheme: +! Ma, Yulong, Cristina L. Archer, and Ahmadreza Vasel-Be-Hagh. "The Jensen wind +! farm parameterization." Wind Energy Science 7.6 (2022): 2407-2431. +! Ma, Yulong, Cristina L. Archer, and Ahmad Vasel‐Be‐Hagh. "Comparison of +! individual versus ensemble wind farm parameterizations inclusive of sub‐grid +! wakes for the WRF model." Wind Energy 25.9 (2022): 1573-1595. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + +#if defined(mpas) + use mpas_dmpar + use mpas_derived_types + + IMPLICIT NONE + INTEGER, PARAMETER :: max_domains = 1 + REAL, PARAMETER :: piconst = 3.141593 + logical, save :: windfarm_initialized = .false. ! MPAS +#else + + USE module_driver_constants, ONLY : max_domains + USE module_model_constants, ONLY : piconst + + USE module_llxy + USE module_dm, ONLY : wrf_dm_min_real, wrf_dm_sum_reals + USE module_configure, ONLY : grid_config_rec_type + + + IMPLICIT NONE +#endif + + INTEGER, PARAMETER :: MAXVALS = 100 + INTEGER :: nt + INTEGER, DIMENSION(:), ALLOCATABLE :: NKIND, NVAL + INTEGER, DIMENSION(:,:), ALLOCATABLE :: ival,jval ! grid number in WRF + REAL, DIMENSION(:), ALLOCATABLE :: hubheight, radius, radius2, diameter, area,& + stc, stc2, cutin, cutout, npower + REAL, DIMENSION(:,:), ALLOCATABLE :: xturb, yturb ! (nt, maxdomain) + REAL, DIMENSION(:,:), ALLOCATABLE :: turbws, turbtc, turbpw, turbpwcof ! (nt,maxvals) + + REAL :: correction_factor + + CONTAINS + + !====================================================================== + + subroutine dragforce_mav(itimestep & + &,id & + &,z_at_w,z_at_m,u,v & + &,dx,dz,dt,tke & + &,du,dv & + &,windfarm_opt,power & + &,windfarm_wake_model, windfarm_overlap_method & + &,xland & +#if defined(mpas) + &,dminfo & + &,windfarm_ij, windfarm_deg & + &,xcell, ycell & +#else + &,cosa,sina & +#endif + &,ids,ide,jds,jde,kds,kde & + &,ims,ime,jms,jme,kms,kme & + &,its,ite,jts,jte,kts,kte & + &) + + implicit none + + integer, intent(in) :: id,windfarm_opt, windfarm_wake_model, windfarm_overlap_method + integer, intent(in) :: its,ite,jts,jte,kts,kte + integer, intent(in) :: ims,ime,jms,jme,kms,kme + integer, intent(in) :: ids,ide,jds,jde,kds,kde + real, intent(in) :: dx, dt + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: dz, u, v, z_at_w, z_at_m + real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: du, dv, tke + real, dimension(ims:ime,jms:jme), intent(in) :: xland + real, dimension(ims:ime,jms:jme), intent(inout) :: power + integer, intent(in) :: itimestep + + real, dimension(ims:ime,kms:kme,jms:jme) :: Uearth, Vearth ! earth-relative u and v + +#if defined(mpas) + type(dm_info),intent(in) :: dminfo + integer, intent(in) :: windfarm_ij + real, intent(in) :: windfarm_deg + real, dimension(ims:ime, jms:jme), intent(in) :: xcell, ycell !hexgon cell center +#else + real, dimension(ims:ime,jms:jme), intent(in) :: cosa,sina +#endif + + ! Local + real :: wfdensity + integer :: itf, jtf, i, j, k + integer :: wake_model, num_models, overlap_method + integer :: wake_model_en(5), overlap_method_en(5) + real, dimension(kms:kme) :: z_tmp + real, dimension(ims:ime,kms:kme,jms:jme) :: tke_wk, du_wk, dv_wk + + real :: kw_nt(nt) + real :: search_angle, search_dis + integer :: ii, tt, kt + integer :: num_ups_pot(nt), ups_indx_pot(nt,nt) ! potential ups turbines + real :: avg_angle_tb(nt,nt) ! potential ups turbines + + integer :: tbindx(nt), num_ups(nt), ups_index(nt,nt) + real :: ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt) + real :: blockfrac(nt), blockdist(nt), rblockdist(nt), ytb_rot_gm(nt,nt) ! GM + logical :: find_tb + real :: u_hub_nt(nt), v_hub_nt(nt), Uinf(nt), ulocal(nt), xland_nt(nt), terrain_nt(nt) + real :: power_nt(nt), power_nt_md(5,nt) + + ! dir avg + integer, parameter :: dir_num = 7 + real, parameter :: dir_avg_window = 5.0 ! +- 2.5 unit [degree] + integer :: dir_ii + real :: dtheta + real :: dtheta_list(7) ! [-2.5, -1.5, -0.5, 0., 0.5, 1.5, 2.5] + real :: dtheta_avg_cof(7) !gaussian distribution + real :: dtheta_std !gaussian distribution std + + ! parallel computing + real :: dm_local_u_hub_nt(nt), dm_global_u_hub_nt(nt) + real :: dm_local_v_hub_nt(nt), dm_global_v_hub_nt(nt) + real :: dm_local_xland_nt(nt), dm_global_xland_nt(nt) + real :: dm_local_terrain_nt(nt), dm_global_terrain_nt(nt) + integer :: ic_tb + + integer,save :: n_valid_cur = 0 + integer :: tb_valid_cur(nt) + + +#if defined(mpas) + wfdensity = 1.0/(dx*dx*sqrt(3.)/2.) +#else + wfdensity = 1.0/(dx*dx) +#endif + + tb_valid_cur(:) = 1 ! set all tbs in operation + + !--------------------------------------------- + ! Gaussion distribution direction avg + dtheta_list(1) = -2.5; dtheta_list(7) = 2.5; + dtheta_list(2) = -1.5; dtheta_list(6) = 1.5; + dtheta_list(3) = -0.5; dtheta_list(5) = 0.5; + dtheta_list(4) = 0. + + dtheta_std = 2.0 ! std [deg] + dtheta_avg_cof(1) = exp(-dtheta_list(1)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(2) = exp(-dtheta_list(2)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(3) = exp(-dtheta_list(3)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(4) = 1. + dtheta_avg_cof(7) = dtheta_avg_cof(1) + dtheta_avg_cof(6) = dtheta_avg_cof(2) + dtheta_avg_cof(5) = dtheta_avg_cof(3) + + dtheta_avg_cof(:) = dtheta_avg_cof(:)/sum(dtheta_avg_cof) + !--------------------------------------------- + + ! + ! for parallel computing + ! + itf = MIN0(ite,ide-1) + jtf = MIN0(jte,jde-1) + + dm_local_u_hub_nt(:) = 0. + dm_local_v_hub_nt(:) = 0. + dm_local_xland_nt(:) = 0. + dm_local_terrain_nt(:) = 0. + dm_global_u_hub_nt(:) = 0. + dm_global_v_hub_nt(:) = 0. + dm_global_xland_nt(:) = 0. + dm_global_terrain_nt(:) = 0. + ic_tb = 0 + +#if defined(mpas) + do kt = 1, nt + i = ival(kt,id) + j = jval(kt,id) + if (i >= its .and. i <= itf .and. j >= jts .and. j <= jtf) then + ic_tb = ic_tb + 1 + z_tmp = z_at_m(i,:,j) - z_at_w(i,1,j) ! mass point height + call to_zk2(hubheight(kt), z_tmp(1:kme-1), u(i,1:kme-1,j), kme-1, dm_local_u_hub_nt(kt)) + call to_zk2(hubheight(kt), z_tmp(1:kme-1), v(i,1:kme-1,j), kme-1, dm_local_v_hub_nt(kt)) + end if + end do + call mpas_dmpar_sum_real_array(dminfo, nt, dm_local_u_hub_nt, dm_global_u_hub_nt) + call mpas_dmpar_sum_real_array(dminfo, nt, dm_local_v_hub_nt, dm_global_v_hub_nt) + +#else + + + ! ---- WRF grid related wind direction to earth related direction --- + ! for Non Mercator projection, the wind direction should be rotated to earth + ! coordinates (where U would be west-east and V would be north-south) + ! https://www2.mmm.ucar.edu/wrf/users/FAQ_files/Miscellaneous.html + DO j = jts, min(jte,jde-1) + DO k = kts, kte-1 + DO i = its, min(ite,ide-1) + Uearth(i,k,j) = U(i,k,j)*cosa(i,j) - V(i,k,j)*sina(i,j) + Vearth(i,k,j) = V(i,k,j)*cosa(i,j) + U(i,k,j)*sina(i,j) + ENDDO + ENDDO + ENDDO + + do kt = 1, nt + i = ival(kt,id) + j = jval(kt,id) + if (i >= its .and. i <= itf .and. j >= jts .and. j <= jtf) then + ic_tb = ic_tb + 1 + z_tmp = z_at_m(i,:,j) - z_at_w(i,1,j) ! mass point height + call to_zk2(hubheight(kt), z_tmp(1:kme-1), Uearth(i,1:kme-1,j), kme-1, dm_local_u_hub_nt(kt)) + call to_zk2(hubheight(kt), z_tmp(1:kme-1), Vearth(i,1:kme-1,j), kme-1, dm_local_v_hub_nt(kt)) + + dm_local_xland_nt(kt) = xland(i,j) + dm_local_terrain_nt(kt) = z_at_w(i,1,j) + end if + + ! if turbine kt is out of the whole domain (i or j == -9999), assume it is not at + ! upstream of any turbines (distance >= 20D), set xturb, yturb to a large value + ! and set uhub, vhub to a small value. It should have no effects on the rest of turbines. + if (i == -9999 .or. j == -9999) then + tb_valid_cur(kt) = 0 + dm_local_u_hub_nt(kt) = 1.e-3 + dm_local_v_hub_nt(kt) = 1.e-3 + endif + end do + + call wrf_dm_sum_reals(dm_local_u_hub_nt, dm_global_u_hub_nt) + call wrf_dm_sum_reals(dm_local_v_hub_nt, dm_global_v_hub_nt) + call wrf_dm_sum_reals(dm_local_xland_nt, dm_global_xland_nt) + call wrf_dm_sum_reals(dm_local_terrain_nt, dm_global_terrain_nt) +#endif + + u_hub_nt(:) = dm_global_u_hub_nt(:) + v_hub_nt(:) = dm_global_v_hub_nt(:) + xland_nt(:) = dm_global_xland_nt(:) + terrain_nt(:) = dm_global_terrain_nt(:) + + !if (ic_tb == 0) return ! no turbine in this tile, no need to do the rest part + + + ! + ! potential ups turbines in a fan-shaped region + ! + Uinf(:) = sqrt(u_hub_nt(:)**2 + v_hub_nt(:)**2) ! hub height speed + + search_angle = 30.*piconst/180. ! +-30 deg, a wider region because of wind dir avg + search_dis = 20.*diameter(1) ! 20D + num_ups_pot(:) = 0 + do kt = 1, nt + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + ii = 0 + do tt = 1, nt + if (tt == kt) cycle + find_tb = find_turb(xturb(kt,id), yturb(kt,id), xturb(tt,id), yturb(tt,id), & + u_hub_nt(kt), v_hub_nt(kt), search_angle, search_dis) + if (find_tb) then + ii = ii + 1 + ups_indx_pot(kt, ii) = tt + avg_angle_tb(kt, tt) = atan2(v_hub_nt(kt)+v_hub_nt(tt), u_hub_nt(kt)+u_hub_nt(tt)) + end if + end do + num_ups_pot(kt) = ii + end do + + + ! + ! dir avg start + ! + tke_wk(:,:,:) = 0. + du_wk(:,:,:) = 0. + dv_wk(:,:,:) = 0. + power(:,:) = 0. + power_nt(:) = 0. ! output to a txt file + power_nt_md(:,:) = 0. ! output to a txt file + + !------------------- Ensemble --------------------- + if (windfarm_wake_model <= 3) then + num_models = 1 + wake_model_en(1) = windfarm_wake_model + overlap_method_en(1) = windfarm_overlap_method + + ! 1=JS, 2=XA, 3=GM + else if (windfarm_wake_model == 4) then ! JS-M4 + XA-M3 + num_models = 2 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + + else if (windfarm_wake_model == 5) then ! JS-M4 + XA-M3 + GM + num_models = 3 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + wake_model_en(3) = 3; overlap_method_en(3) = 2 + + else if (windfarm_wake_model == 6) then ! JS-M3 + JS-M4 + XA-M3 + GM, single-cell + num_models = 4 + wake_model_en(1) = 1; overlap_method_en(1) = 3 + wake_model_en(2) = 1; overlap_method_en(2) = 4 + wake_model_en(3) = 2; overlap_method_en(3) = 3 + wake_model_en(4) = 3; overlap_method_en(4) = 2 + + else if (windfarm_wake_model == 7) then ! JS-M4 + XA-M3 + XA-M4 + GM, multi-cell + num_models = 4 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + wake_model_en(3) = 2; overlap_method_en(3) = 4 + wake_model_en(4) = 3; overlap_method_en(4) = 2 + end if + !------------------- Ensemble --------------------- + + do dir_ii = 1, dir_num ! dir avg loop + if (dir_num > 1) then + !dtheta = -(0.5*dir_avg_window - (dir_ii-1.)/(dir_num-1.)*dir_avg_window)/180.*piconst + dtheta = dtheta_list(dir_ii)/180.*piconst + else + dtheta = 0. + end if + + do ii = 1, num_models + wake_model = wake_model_en(ii) + overlap_method = overlap_method_en(ii) + + ! actual upstream turbines (overlap area > 0) + call ups_turbs(kw_nt, ao_ups, ax_dist, ay_dist, az_dist, ytb_rot_gm, ups_index, num_ups, & + num_ups_pot, ups_indx_pot, avg_angle_tb, xturb(:,id), yturb(:,id), & + radius, area, hubheight, xland_nt, terrain_nt, nt, dtheta, wake_model) + + ! sort all turbines from the most upstream turbine + ! NOT BASED on ax_dist because they are not at the same diretion. + ! (a directed graph problem) + call sort_turb(nt, num_ups, ups_index, tbindx) + + ! cal. def and local speed + if (wake_model == 1) then + call cal_tb_ulocal_JS(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, Ao_ups, kw_nt, nt, radius, tb_valid_cur, overlap_method) + + else if (wake_model == 2) then + call cal_tb_ulocal_XA(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, Ao_ups, & + nt, radius, radius2, tb_valid_cur, overlap_method) + + else if (wake_model == 3) then + call cal_tb_ulocal_GM(ulocal, blockfrac, blockdist, rblockdist, & + uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, ytb_rot_gm, & + nt, radius, tb_valid_cur) + end if + + ! cal power and WRF tendencies + call cal_power_wrf_tend(ulocal, uinf, tb_valid_cur, blockfrac, blockdist, u, v, dz, z_at_w, & + ival(:,id), jval(:,id), nt, radius, diameter, hubheight, area, & + wake_model, wfdensity, dt, & + power_nt_md(ii,:), power, tke_wk, du_wk, dv_wk, dtheta_avg_cof(dir_ii), & + ims,ime,jms,jme,kms,kme,its,itf,jts,jtf) + end do + end do + + tke_wk = tke_wk/num_models + du_wk = du_wk/num_models + dv_wk = dv_wk/num_models + power = power/num_models + + tke = tke_wk ! turbine generated TKE + du = du + du_wk + dv = dv + dv_wk + + do ii = 1, num_models + power_nt(:) = power_nt(:) + power_nt_md(ii,:) + enddo + power_nt = power_nt/num_models + + ! write fraction power of each turbine to a txt at 4 hr + !call write_power_txt(windfarm_wake_model, windfarm_overlap_method, itimestep, dt, its, jts, & + ! dx, power_nt, power_nt_md, ulocal, nt, num_models) + + end subroutine dragforce_mav + + +!============================================================================== +!============================================================================== + + + subroutine write_power_txt(windfarm_model, windfarm_method, itimestep, dt, its, jts, & + dx, power_nt, power_nt_md, ulocal, nt, num_models) + ! this function might be improved later. + implicit none + integer :: nt, windfarm_model, windfarm_method, itimestep, its, jts, num_models + real :: dx, power_nt(nt), ulocal(nt), power_nt_md(5,nt), dt + integer :: it_out, ii, i, j, kt + integer,save :: it_init = 0, write_out = 0 + character(len=1024) :: fmt_my, str_my, fn_my + real :: out_hr, max_power + + out_hr = 4. ! hr + + if (it_init == 0) it_init = itimestep + + write (str_my, "(I1)") windfarm_method + + IF (windfarm_model == 1) THEN + fn_my = 'power_nt_JS_M'//trim(str_my)//'.txt_5.0d_0.25' + ELSEIF (windfarm_model == 2) THEN + fn_my = 'power_nt_XA_M'//trim(str_my)//'.txt_5.0d_0.25' + ELSEIF (windfarm_model == 3) THEN + IF (windfarm_method == 2) fn_my = 'power_nt_GM_MC.txt_5.0d_0.25' + IF (windfarm_method == 3) fn_my = 'power_nt_GM_AN.txt_5.0d' + ENDIF + + IF (windfarm_model == 4) fn_my = 'power_nt_EN2.txt_5.0d_0.25' + IF (windfarm_model == 5) fn_my = 'power_nt_EN3.txt_5.0d_0.25' + + IF (windfarm_model == 6) fn_my = 'power_nt_EN6.txt_2.5d' + IF (windfarm_model == 7) fn_my = 'power_nt_EN7.txt_2.5d' + + + !if (itimestep == it_out .and. its == 1 .and. jts == 1) then + if ((itimestep-it_init)*dt >= 4.*3600. .and. write_out == 0 .and. its == 1 .and. jts == 1) then + write_out = 1 + + write(*,*) 'output relative power', (itimestep-it_init)*dt + OPEN ( FILE = fn_my, UNIT = 923) + write (str_my, "(I6)") nt + fmt_my = '('//trim(str_my)//'F12.2)' + + write(923,FMT=fmt_my) power_nt(1:nt) + + do ii = 1, num_models + write(923,FMT=fmt_my) power_nt_md(ii,1:nt) + end do + + write(923,FMT=fmt_my) ulocal(1:nt) + CLOSE(923) + + endif + end subroutine write_power_txt + +!--------------------------------------------------------------- + + subroutine ups_turbs( kw_nt, ao_ups, ax_dist, ay_dist, az_dist, ytb_rot_gm, ups_index, num_ups, & + num_ups_pot, ups_indx_pot, avg_angle_tb, xturb, yturb, & + radius, area, hubheight, xland_nt, terrain_nt, nt, dtheta, windfarm_model) + implicit none + integer, intent(in) :: nt, num_ups_pot(nt), ups_indx_pot(nt,nt), windfarm_model + real, intent(in) :: avg_angle_tb(nt,nt), xturb(nt), yturb(nt), & + radius(nt), area(nt), hubheight(nt), xland_nt(nt), terrain_nt(nt) + real, intent(out) :: ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt), & + ytb_rot_gm(nt,nt), kw_nt(nt) + integer, intent(out) :: ups_index(nt,nt), num_ups(nt) + real :: dtheta + + integer :: num_ups_turb, tt, jt, kt, ii + real :: cur_tb_ang, ax_GM(nt), x_ups_tmp, y_ups_tmp, x_cur, y_cur, & + axialdist, Ao, wakewidth + real :: kw_tmp, kw_test(nt), kw + + !----------------------- + do kt = 1, nt + if (xland_nt(kt) > 1.5) then ! water = 2 + kw = 0.04 ! offshore + else if (xland_nt(kt) < 1.5) then ! land = 1 + kw = 0.0075 ! onshore + end if + + if (windfarm_model == 1) then + kw_test(kt) = kw + kw_nt(kt) = kw + else if (windfarm_model == 2) then + kw_test(kt) = 5.*kw ! choose a larger search region for XA + end if + end do + + if (windfarm_model == 3) then + kw_test(:) = 0. ! no wake expandation for GM + end if + !----------------------- + + + do kt = 1, nt + num_ups_turb = 0 + do tt = 1, num_ups_pot(kt) + + jt = ups_indx_pot(kt,tt) + + cur_tb_ang = avg_angle_tb(kt,jt) + dtheta + call coordinate_rotation(x_cur, y_cur, xturb(kt), yturb(kt), cur_tb_ang) + call coordinate_rotation(x_ups_tmp, y_ups_tmp, xturb(jt), yturb(jt), cur_tb_ang) + + axialdist = x_cur - x_ups_tmp + if (axialdist <= 0.) then + Ao = 0. + else + kw_tmp = kw_test(jt) + wakewidth = radius(jt) + kw_tmp*axialdist + Ao = AreaOverlap(y_cur, y_ups_tmp, hubheight(kt)+terrain_nt(kt), & + hubheight(jt)+terrain_nt(jt), radius(kt), wakewidth) + end if + + !if (Ao/area(kt) > 0.) then + if (Ao/area(kt) > 0.01) then + num_ups_turb = num_ups_turb + 1 + ups_index(kt,num_ups_turb) = jt + Ao_ups(kt,jt) = Ao/area(kt) + ax_dist(kt,jt) = axialdist + ay_dist(kt,jt) = y_cur - y_ups_tmp + az_dist(kt,jt) = (hubheight(kt) + terrain_nt(kt)) - & + (hubheight(jt) + terrain_nt(jt)) + + ax_gm(num_ups_turb) = axialdist ! for GM to sort ups turbines + ytb_rot_gm(kt,jt) = y_ups_tmp + end if + + ! used in analytical GM, it changes if ups turbines are + ! in different grid cells, just approximate value here. TO BE IMPROVED! + ytb_rot_gm(kt,kt) = y_cur + + end do + num_ups(kt) = num_ups_turb + + if (windfarm_model == 3 .and. num_ups(kt) > 1) then ! GM model + call sort_gm(num_ups(kt), ups_index(kt,1:num_ups(kt)), ax_gm(1:num_ups(kt))) + end if + + end do + + end subroutine ups_turbs + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_JS(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, Ao_ups, kw_nt, nt, radius, tb_valid_cur, overlap_method) + implicit none + real, intent(out) :: ulocal(nt) + real, intent(in ) :: uinf(nt), Ao_ups(nt,nt), ax_dist(nt,nt), radius(nt), kw_nt(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt), overlap_method + integer,intent(in) :: tb_valid_cur(nt) + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + integer :: kt, it, jt, tt, nv + real :: Udef_nt(nt), def_ij, tmp, thrcof + + ulocal(:) = uinf(:) + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + + if (num_ups(it) == 0) cycle + + Udef_nt(:) = 0. + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + nv = nval(jt) + call dragcof(tmp, tmp, thrcof, ulocal(jt), turbws(jt,1:nv), & + turbtc(jt,1:nv), turbpwcof(jt,1:nv), stc(jt), stc2(jt), nv) + + def_ij = (1. - sqrt(1. - thrcof))/(1. + kw_nt(jt)*ax_dist(it,jt)/radius(jt))**2*Ao_ups(it,jt) + + ! wake overlapping methods M1 - M4 + if (overlap_method == 1 .or. overlap_method == 2) then + Udef_nt(jt) = uinf(jt)*def_ij*Ao_ups(it,jt) + + else if (overlap_method == 3) then + Udef_nt(jt) = ulocal(jt)*def_ij*Ao_ups(it,jt) + + ! Here Udef_nt is actually a local U, not a DeltaU + else if (overlap_method == 4) then + Udef_nt(jt) = uinf(it)*(1. - Ao_ups(it,jt)) + uinf(jt)*(1. - def_ij)*Ao_ups(it,jt) + end if + + end do + + if (overlap_method == 1) then + ulocal(it) = Uinf(it) - sum(Udef_nt) + else if (overlap_method == 2 .or. overlap_method == 3) then + ulocal(it) = Uinf(it) - sqrt(sum(Udef_nt**2)) + else if (overlap_method == 4) then + ulocal(it) = sqrt(sum(Udef_nt**2)/num_ups(it)) + end if + + enddo + + end subroutine cal_tb_ulocal_JS + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_XA(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, Ao_ups, & + nt, radius, radius2, tb_valid_cur, overlap_method) + implicit none + real, intent(out) :: ulocal(nt) + real, intent(in ) :: uinf(nt), Ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), & + az_dist(nt,nt), radius(nt), radius2(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt), overlap_method + integer,intent(in) :: tb_valid_cur(nt) + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + real :: ky, kz + integer :: kt, it, jt, tt, nv + real :: Udef_nt(nt), def_ij, tmp, thrcof + real :: beta, eps, sigmay, sigmaz, def_avg + + ! --- Are ky and kz the same over land? + ky = 0.025 + kz = 0.0175 + + ulocal(:) = uinf(:) + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + + if (num_ups(it) == 0) cycle + + Udef_nt(:) = 0. + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + nv = nval(jt) + call dragcof(tmp, tmp, thrcof, ulocal(jt), turbws(jt,1:nv), & + turbtc(jt,1:nv), turbpwcof(jt,1:nv), stc(jt), stc2(jt), nv) + + beta = 0.5*(1. + sqrt(1. - thrcof))/sqrt(1. - thrcof) + eps = 0.25*sqrt(beta) + sigmay = ky*ax_dist(it,jt) + eps*2*radius(jt) + sigmaz = kz*ax_dist(it,jt) + eps*2*radius(jt) + call Gaussian_integral(ay_dist(it,jt), az_dist(it,jt), radius(it), sigmay, sigmaz, def_avg) + def_ij = (1. - sqrt(1.-radius2(jt)*thrcof/sigmay/sigmaz/2.))*def_avg + + ! wake overlapping methods M1 - M4 + if (overlap_method == 1 .or. overlap_method == 2) then + Udef_nt(jt) = Uinf(jt)*def_ij + + else if (overlap_method == 3) then + Udef_nt(jt) = ulocal(jt)*def_ij + + ! Here Udef_nt is actually a local U, not a DeltaU + else if (overlap_method == 4) then + Udef_nt(jt) = Uinf(jt)*(1. - def_ij) + end if + end do + + if (overlap_method == 1) then + ulocal(it) = Uinf(it) - sum(Udef_nt) + else if (overlap_method == 2 .or. overlap_method == 3) then + ulocal(it) = Uinf(it) - sqrt(sum(Udef_nt**2)) + else if (overlap_method == 4) then + ulocal(it) = sqrt(sum(Udef_nt**2)/num_ups(it)) + end if + end do + + end subroutine cal_tb_ulocal_XA + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_GM(ulocal, blockfrac, blockdist, rblockdist, & + uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, ytb_rot_gm, & + nt, radius, tb_valid_cur) + implicit none + real, intent(out) :: ulocal(nt), blockfrac(nt), blockdist(nt), rblockdist(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt) + real, intent(in) :: uinf(nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt), & + ytb_rot_gm(nt,nt), radius(nt) + integer,intent(in) :: tb_valid_cur(nt) + integer :: kt, it + real :: gfun_GM + + integer, parameter :: ndisk = 50 ! 50x50 samples for montecarlo + real, parameter :: MAXD = 20. ! upsteam within 20d + integer :: ii, jd, kd, jt, tt, nblock + integer :: ndiskpt + real :: diskpt(ndisk) + real :: distblk(ndisk,ndisk), rdistblk(ndisk,ndisk) + real :: scaled_axdist(nt), raxdist(nt) + integer :: on_disk(ndisk,ndisk) + real :: on_disk_1d(ndisk*ndisk) + real :: on_disk_1d_y(ndisk*ndisk), on_disk_1d_z(ndisk*ndisk) + real :: on_disk_1d_yr(ndisk*ndisk), on_disk_1d_zr(ndisk*ndisk) + real :: distblk_1d(ndisk*ndisk), rdistblk_1d(ndisk*ndisk) + + integer, parameter :: cal_method = 2 ! 1 : analytical, 2 = montecarlo + + ulocal(:) = uinf(:) + + if (cal_method == 2) then + + do ii = 1, ndisk + diskpt(ii) = -1. + (ii-0.5)/ndisk*2. + end do + + !on_disk(:,:) = 0 + on_disk_1d(:) = 0. + on_disk_1d_y(:) = 0. + on_disk_1d_z(:) = 0. + ndiskpt = 0 + do jd = 1, ndisk + do kd = 1, ndisk + if (diskpt(jd)**2 + diskpt(kd)**2 < 1.) then + ndiskpt = ndiskpt + 1 + !on_disk(jd,kd) = 1 + on_disk_1d(ndiskpt) = 1. + on_disk_1d_y(ndiskpt) = diskpt(jd) + on_disk_1d_z(ndiskpt) = diskpt(kd) + endif + end do + end do + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interest + + if (num_ups(it) == 0) then + blockfrac(it) = 0. + else + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + scaled_axdist(jt) = ax_dist(it,jt)/(MAXD*2.*radius(jt)) ! scaled by 20*diameter + raxdist(jt) = 1./ax_dist(it,jt) + end do + + nblock = 0 + + on_disk_1d_yr(1:ndiskpt) = on_disk_1d_y(1:ndiskpt)*radius(it) + on_disk_1d_zr(1:ndiskpt) = on_disk_1d_z(1:ndiskpt)*radius(it) + + !--- montecarlo 1 --- + distblk_1d(1:ndiskpt) = on_disk_1d(1:ndiskpt) + rdistblk_1d(1:ndiskpt) = 0. + do ii = 1, ndiskpt ! on tb it + do tt = num_ups(it), 1, -1 ! starting from the closest turbine + jt = ups_index(it,tt) + if ((on_disk_1d_yr(ii) - ay_dist(it,jt))**2 + & ! on tb jt + (on_disk_1d_zr(ii) - az_dist(it,jt))**2 < radius2(jt)) then + nblock = nblock + 1 + distblk_1d(nblock) = scaled_axdist(jt) ! ax_dist(jt)/(20*diameter(it)) + rdistblk_1d(nblock) = raxdist(jt) ! 1./ax_dist(jt) + exit + end if + end do + end do + blockdist(it) = sum(distblk_1d(1:ndiskpt))/ndiskpt + rblockdist(it) = sum(rdistblk_1d(1:ndiskpt))/ndiskpt + !--- montecarlo 1 --- + + + !--- montecarlo 2 --- + !!on_disk and ndiskpt are the same for all turbines, already calculated + !!set distblk(jd,kd) = 1. on turbine (= 0 out of turbine) + !distblk(:,:) = on_disk(:,:)*1.0 + !rdistblk(:,:) = 0. + !do jd = 1, ndisk + !do kd = 1, ndisk + ! if (on_disk(jd,kd) == 1) then ! on turbine it + ! do tt = num_ups(it), 1, -1 ! starting from the closest turbine + ! jt = ups_index(it,tt) + ! if ((diskpt(jd)*radius(it) - ay_dist(it,jt))**2 + & ! on tb jt + ! (diskpt(kd)*radius(it) - az_dist(it,jt))**2 < radius2(jt)) then + ! nblock = nblock + 1 + ! distblk(jd,kd) = scaled_axdist(jt) ! ax_dist(jt)/(20*diameter(it)) + ! rdistblk(jd,kd) = raxdist(jt) ! 1./ax_dist(jt) + ! exit + ! end if + ! end do + ! end if + !end do + !end do + !blockdist(it) = sum(distblk)/ndiskpt + !rblockdist(it) = sum(rdistblk)/ndiskpt + !--- montecarlo 2 --- + + + blockfrac(it) = float(nblock)/ndiskpt + if (blockdist(it) > 1.) blockfrac(it) = 0. + end if ! num_ups(it) > 0 + + !--- + if (blockfrac(it) == 0.) then + gfun_GM = 1. + else + gfun_GM = 0.9615 - 0.1549*blockfrac(it) - 0.0114*rblockdist(it)*20.*2*radius(it) + end if + ulocal(it) = Uinf(it)*gfun_GM + enddo + endif + + + if (cal_method == 1) then + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + call gm_BD_BR_analytical(blockfrac(it), blockdist(it), rblockdist(it), & + radius(it), num_ups(it), ups_index(it,1:nt), nt, it, & + ax_dist(it,1:nt), ytb_rot_gm(it,1:nt)) + if (blockfrac(it) == 0.) then + gfun_GM = 1. + else + gfun_GM = 0.9615 - 0.1549*blockfrac(it) - 0.0114*rblockdist(it)*20.*2*radius(it) + end if + ulocal(it) = Uinf(it)*gfun_GM + enddo + endif + end subroutine cal_tb_ulocal_GM + +!--------------------------------------------------------------- + + subroutine cal_power_wrf_tend(ulocal, uinf, tb_valid_cur, blockfrac, blockdist, u, v, dz, z_at_w, & + ival, jval, nt, radius, diameter, hubheight, area, & + windfarm_model, wfdensity, dt, & + power_nt, power, tke_wk, du_wk, dv_wk, dtheta_avg_cof_i, & + ims,ime,jms,jme,kms,kme,its,itf,jts,jtf) + implicit none + integer :: ims, ime, jms, jme, kms, kme, its, itf, jts, jtf + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: u, v, dz, z_at_w + real, dimension(ims:ime,kms:kme,jms:jme) :: tke_wk, du_wk, dv_wk ! wrf output + real, dimension(ims:ime,jms:jme) :: power ! wrf output + real :: power_nt(nt) ! output + real :: dtheta_avg_cof_i !gaussian distribution + + integer :: nt, ival(nt), jval(nt), windfarm_model + real :: ulocal(nt), Uinf(nt), blockfrac(nt), blockdist(nt) + real :: radius(nt), diameter(nt), hubheight(nt), area(nt), wfdensity, dt + integer :: tb_valid_cur(nt) + + integer :: kt, nv, i, j, k + real, dimension(kms:kme) :: speed_z, tarea_z, power2_z, z_tmp + real :: power_GM, power1, power2, ec, tkecof, powcof, thrcof + real :: blade_l_point,blade_u_point,z1,z2 + integer :: k_turbine_bot, k_turbine_top + real :: tmp_spd + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + ! power for each tb + !IF (windfarm_model == 3) THEN ! GM model + !! YL: For multi-grid cases, I don't have a solution for actual power by GM. + !! It might be scale with the maximun power for the wind farm. + ! IF (blockfrac(kt) == 0.) THEN + ! power_GM = 1. + ! ELSE + ! power_GM = 0.6824 - 0.3405*blockfrac(kt) + 0.2131*blockdist(kt) + ! ENDIF + !ENDIF + + nv = nval(kt) + call dragcof(tkecof, powcof, thrcof, & + ulocal(kt), turbws(kt,1:nv), turbtc(kt,1:nv), & + turbpwcof(kt,1:nv), stc(kt), stc2(kt), nv) + + power1 = 0.5*1.23*ulocal(kt)**3*area(kt)*powcof ! 1.23 density + + power_nt(kt) = power_nt(kt) + power1*dtheta_avg_cof_i + !!------- end power for each tb -------- + + + !----------- WRF tendencies ------------ + ! only considering turbines in the current tile + ! the follwoing code is based on Fitch parameterization + + i = ival(kt) + j = jval(kt) + if (i > itf .or. i < its .or. j > jtf .or. j < jts ) cycle + + ! vertical layers cut by turbine blades + blade_l_point = hubheight(kt) - radius(kt) + blade_u_point = hubheight(kt) + radius(kt) + k_turbine_bot = 0 !bottom level + k_turbine_top = -1 !top level + z_tmp = z_at_w(i,:,j) - z_at_w(i,1,j) + do k = kms, kme-1 + if (blade_l_point >= z_tmp(k) .and. blade_l_point < z_tmp(k+1)) then + k_turbine_bot = k + end if + if (blade_u_point >= z_tmp(k) .and. blade_u_point < z_tmp(k+1)) then + k_turbine_top = k + end if + end do + + ! adjust coef. according to disk averaged power + power2_z(:) = 0. + do k = k_turbine_bot, k_turbine_top ! loop over turbine blade levels + z1 = max(z_tmp(k) - blade_l_point, 0.) + z2 = min(z_tmp(k+1) - blade_l_point, diameter(kt)) + CALL turbine_area(z1, z2, diameter(kt), tarea_z(k)) + + speed_z(k) = ulocal(kt)/Uinf(kt)*sqrt(u(i,k,j)**2 + v(i,k,j)**2) + power2_z(k) = 0.5*1.23*speed_z(k)**3*tarea_z(k)*powcof + end do + power2 = sum(power2_z) + if (power1 == 0. .or. power2 == 0.) then + ec = 1. + else + ec = power1/power2 + end if + !ec = ec*wfdensity + ec = ec*wfdensity*dtheta_avg_cof_i + + power(i,j) = power(i,j) + power2*dtheta_avg_cof_i ! WRF output + + do k = k_turbine_bot, k_turbine_top ! loop over turbine blade levels + !qke_wk(i,k,j) = qke_wk(i,k,j) + speed_z(k)**3*tarea_z(k)*tkecof*dt/dz(i,k,j)*ec + tke_wk(i,k,j) = tke_wk(i,k,j) + 0.5*speed_z(k)**3*tkecof*tarea_z(k)/dz(i,k,j)*dt*ec + du_wk(i,k,j) = du_wk(i,k,j) - 0.5*u(i,k,j)*thrcof*speed_z(k)*tarea_z(k)/dz(i,k,j)*ec + dv_wk(i,k,j) = dv_wk(i,k,j) - 0.5*v(i,k,j)*thrcof*speed_z(k)*tarea_z(k)/dz(i,k,j)*ec + end do + + end do + + end subroutine cal_power_wrf_tend + +!--------------------------------------------------------------- + + subroutine sort_turb(nt, num_ups, ups_index, tbindx) + implicit none + integer, intent(in) :: nt + integer, intent(in) :: num_ups(nt), ups_index(nt,nt) + integer, intent(inout) :: tbindx(nt) + integer :: ic_tb, indx, kt, tt, flag(nt) + + flag(:) = 0 + ic_tb = 0 + + do kt = 1, nt + if (num_ups(kt) == 0) then + ic_tb = ic_tb + 1 + flag(kt) = 1 + tbindx(ic_tb) = kt ! sorted turb starting from upstream + end if + end do + + do while (ic_tb < nt) + do kt = 1, nt + if (flag(kt) == 1) cycle + + do tt = 1, num_ups(kt) + indx = ups_index(kt,tt) + if (flag(indx) == 0) exit + + if (tt == num_ups(kt)) then + ic_tb = ic_tb + 1 + flag(kt) = 1 + tbindx(ic_tb) = kt + end if + end do + end do + enddo + + if (sum(flag) < nt) then + write(*,*) 'something wrong in sorting turbine, wind_jensen/sort_turb' + write(*,*) tbindx + stop + end if + + endsubroutine sort_turb + +!--------------------------------------------------------------- + + subroutine sort_gm(nturb, tbindx, ax_dist) + implicit none + integer, intent(in) :: nturb + integer, intent(out), dimension(nturb) :: tbindx + real, intent(inout), dimension(nturb) :: ax_dist + real, dimension(nturb) :: xloc + integer :: i, a(1) + real :: xmin + integer :: tbindx_cp(nturb) + + xloc = ax_dist + tbindx_cp = tbindx + xmin = minval(xloc) - 1. + + do i = 1, nturb + a = maxloc(xloc) + tbindx(i) = tbindx_cp(a(1)) + xloc(a(1)) = xmin + end do + + end subroutine sort_gm + +!--------------------------------------------------------------- + +!--------------------------------------------------------------- + + subroutine gm_BD_BR_analytical(blockfrac, blockdist, rblockdist, & + radius, num_ups, ups_index, nt, it, ax_dist, y) + implicit none + integer :: nt, num_ups, it + integer :: ups_index(nt) + real :: ax_dist(nt), y(nt) + real :: scaled_axdist(nt), raxdist(nt) + real :: radius + real, intent(out) :: blockfrac, blockdist, rblockdist + + real, parameter :: MAXD = 20. ! upsteam within 20d + integer, parameter :: ndisk = 80 + real :: diameter, radius2, d, BR, BD, mindr, mindl + integer :: tt, jt, numuptl, numuptr, jmindisl, jmindisr + real :: blockdist_ups(nt), blockfrac_ups(nt), rblockdist_ups(nt) + + if (num_ups == 0) then + blockfrac = 0. + return + endif + + diameter = radius*2 + radius2 = radius**2 + + blockfrac_ups(:) = 0. + blockdist_ups(:) = 0. + rblockdist_ups(:) = 0. + + mindr = diameter + mindl = diameter + numuptl = 0 + numuptr = 0 + jmindisl = 0 + jmindisr = 0 + + ! only look for 4 upstream turbines ??? YL + + do tt = num_ups, 1, -1 ! starting from the closest turbine + jt = ups_index(tt) + if (ax_dist(jt) > maxd*diameter) exit ! only consider ups tbs within 20d + + !-------------------- + d = y(jt) - y(it) + + if (d <= 0.) then !upstream turbine on the left side of (or on) the centerline + numuptl = numuptl + 1 + if (abs(d) > mindl) then + blockfrac_ups(jt) = 0. + else + if (numuptl == 1) then + if (numuptr == 0) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + else + if ( abs(d) + mindr < diameter ) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + end if + end if + else + if (numuptr > 0 .and. abs(d) + mindr < diameter) then + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + end if + else + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) + end if + end if + end if + mindl = abs(d) + jmindisl = jt + + ! don't need to look for further ups tbs + if (d == 0.) then + blockdist_ups(jt) = blockfrac_ups(jt)*ax_dist(jt)/(MAXD*diameter) + rblockdist_ups(jt) = blockfrac_ups(jt)/ax_dist(jt) + exit + end if + + end if + + else !upstream turbine on the right side of the centerline + numuptr = numuptr + 1 + if (abs(d) > mindr) then + blockfrac_ups(jt) = 0. + else + if (numuptr == 1) then + if (numuptl == 0) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + else + if ( abs(d) + mindl < diameter ) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + end if + end if + else + if (numuptl > 0 .and. abs(d) + mindl < diameter) then + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + end if + else + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) + end if + end if + end if + mindr = abs(d) + jmindisr = jt + end if + end if !center, left and right are all done for blockfrac_ups(jt) + + blockdist_ups(jt) = blockfrac_ups(jt)*ax_dist(jt)/(MAXD*diameter) + rblockdist_ups(jt) = blockfrac_ups(jt)/ax_dist(jt) + + end do + + BR = sum(blockfrac_ups) + BD = sum(blockdist_ups) + 1.*(1.-BR) ! normalized dist for non-blocked part is 1. + + blockfrac = BR + blockdist = BD + rblockdist = sum(rblockdist_ups) + + if (blockdist > 1.) blockfrac = 0. + + end subroutine gm_BD_BR_analytical + +!--------------------------------------------------------------- + + function Ao_GM(x1, x2, Radius) result(Ao) + implicit none + real,intent(in) :: x1,x2,Radius + real :: Ao + real :: d, l, theta, Asector, Atriangle + + Ao = 0. + d = sqrt((x1-x2)**2) + if (d<2*Radius) then + l = d/2. !Improve later in case hubs are not at same height + theta = 2 * acos(l/Radius) + Asector = theta/2.*Radius**2 + Atriangle = l*Radius*sin(theta/2.) + Ao = 2*(Asector - Atriangle)/(piconst*radius**2) + end if + + end function Ao_GM + +!--------------------------------------------------------------- + + function AreaOverlap(y1, y2, z1, z2, r1, r2) result(AOverlap) + implicit none + real,intent(in) :: y1, y2, z1, z2, r1, r2 + real :: AOverlap + real :: c, CBD, CAD + + c = sqrt((z1-z2)**2 + (y1-y2)**2) + + if ((c + min(r2,r1)) <= max(r2,r1)) then + AOverlap = piconst*min(r2,r1)**2 + else if ((r1 + r2) <= c) then + AOverlap = 0. + else + CBD = acos((r2**2 + c**2 - r1**2)/(2*r2*c)) + CAD = acos((r1**2 + c**2 - r2**2)/(2*r1*c)) + AOverlap = CBD*r2**2 + CAD*r1**2 - 0.5*r2**2*sin(2*CBD) - 0.5*r1**2*sin(2*CAD) + !AOverlap = CBD*r2**2 + CAD*r1**2 - r1*c*sin(CAD) + end if + + end function AreaOverlap + +!--------------------------------------------------------------- + + function find_turb(xc, yc, xt, yt, u, v, sr_angle, sr_dis) result(ft) + implicit none + logical :: ft + real :: xc, yc, xt, yt, sr_angle, sr_dis, u, v + real :: posi_angle, posi_dis, spd, xp, yp, angle + real ( kind = 8 ) :: tmp1, tmp2 + + ft = .false. + + xp = xt - xc + yp = yt - yc + posi_dis = sqrt(yp**2 + xp**2) + + if (posi_dis <= sr_dis) then + posi_angle = atan2(-yp, -xp) + spd = sqrt(u**2 + v**2) + !tmp1 = -(u*xp + v*yp) ! negative means ups diretion + tmp1 = real( -(u*xp + v*yp), kind = 8 ) + tmp2 = real( sqrt( (u**2 + v**2) * (xp**2 + yp**2) ), kind = 8) + + if (abs(tmp2) < abs(tmp1)) then + tmp2 = sign(tmp1,tmp2) + end if + + angle = real(acos(tmp1/tmp2), kind = 4) + + if (isnan(angle)) then + angle = 0. + end if + + if (abs(angle) <= sr_angle) then + ft = .true. + end if + end if + + end function find_turb + +!--------------------------------------------------------------- + + subroutine coordinate_rotation(xr, yr, x, y, theta) + implicit none + real :: xr, yr, x, y, theta + xr = x*cos(theta) + y*sin(theta) + yr = -x*sin(theta) + y*cos(theta) + end subroutine coordinate_rotation + +!--------------------------------------------------------------- + + subroutine Gaussian_integral(ch, ck, R, sigma_x, sigma_y, avg_val) + ! integration of Gaussian distribution over an offset circle: + ! (x-ch)**2 + (y-ck)**2 <= R**2 + ! DiDonato and Jarnagin, 1961 + implicit none + real, intent(in) :: ch, ck, R, sigma_x, sigma_y + real :: d01, d11, t, A, P, avg_val, sum_val + real :: WW(24), XX(24) ! 24 point gaussian quadrature integral for 1D function + integer :: i + + ! https://pomax.github.io/bezierinfo/legendre-gauss.html + WW( 1)=0.1279381953467522; XX( 1)= -0.0640568928626056 + WW( 2)=0.1279381953467522; XX( 2)= 0.0640568928626056 + WW( 3)=0.1258374563468283; XX( 3)= -0.1911188674736163 + WW( 4)=0.1258374563468283; XX( 4)= 0.1911188674736163 + WW( 5)=0.1216704729278034; XX( 5)= -0.3150426796961634 + WW( 6)=0.1216704729278034; XX( 6)= 0.3150426796961634 + WW( 7)=0.1155056680537256; XX( 7)= -0.4337935076260451 + WW( 8)=0.1155056680537256; XX( 8)= 0.4337935076260451 + WW( 9)=0.1074442701159656; XX( 9)= -0.5454214713888396 + WW(10)=0.1074442701159656; XX(10)= 0.5454214713888396 + WW(11)=0.0976186521041139; XX(11)= -0.6480936519369755 + WW(12)=0.0976186521041139; XX(12)= 0.6480936519369755 + WW(13)=0.0861901615319533; XX(13)= -0.7401241915785544 + WW(14)=0.0861901615319533; XX(14)= 0.7401241915785544 + WW(15)=0.0733464814110803; XX(15)= -0.8200019859739029 + WW(16)=0.0733464814110803; XX(16)= 0.8200019859739029 + WW(17)=0.0592985849154368; XX(17)= -0.8864155270044011 + WW(18)=0.0592985849154368; XX(18)= 0.8864155270044011 + WW(19)=0.0442774388174198; XX(19)= -0.9382745520027328 + WW(20)=0.0442774388174198; XX(20)= 0.9382745520027328 + WW(21)=0.0285313886289337; XX(21)= -0.9747285559713095 + WW(22)=0.0285313886289337; XX(22)= 0.9747285559713095 + WW(23)=0.0123412297999872; XX(23)= -0.9951872199970213 + WW(24)=0.0123412297999872; XX(24)= 0.9951872199970213 + + sum_val = 0. + do i = 1, 24 ! 24 point gaussian quadrature integral + t = 0.5*XX(i) + 0.5 + d01 = (ck - R*t*sqrt(2.-t**2))/(sqrt(2.)*sigma_y) + d11 = (ck + R*t*sqrt(2.-t**2))/(sqrt(2.)*sigma_y) + P = (exp(-0.5*( (ch - R*(1.-t**2))/sigma_x )**2) + & + exp(-0.5*( (ch + R*(1.-t**2))/sigma_x )**2)) * & + (erf(d11) - erf(d01))*t + sum_val = sum_val + 0.5*WW(i)*P + end do + !A = R/sigma_y/np.sqrt(2*np.pi) ! normalized gaussian distribution + A = (2*piconst*sigma_x*sigma_y) * R/sigma_x/sqrt(2*piconst) + avg_val = A*sum_val/(piconst*R**2) + + end subroutine Gaussian_integral + +!--------------------------------------------------------------- + + subroutine to_zk2(obs_v, mdl_v, mdl_data, iz, interp_out ) + ! 1D interp function + implicit none + integer :: k, iz, k1 + real, intent(in) :: obs_v + real, dimension(1:iz), intent(in) :: mdl_v, mdl_data + real, intent(out) :: interp_out + real :: dz, dzm, zk + + if (obs_v < mdl_v(1) ) then + interp_out = mdl_data(1) + return + else if (obs_v >= mdl_v(iz)) then + interp_out = mdl_data(iz) + return + else + do k = 1,iz-1 + if(obs_v >= mdl_v(k) .and. obs_v < mdl_v(k+1)) then + zk = real(k) + (obs_v - mdl_v(k))/(mdl_v(k+1) - mdl_v(k)) + exit + end if + end do + k1 = int( zk ) + dz = zk - float( k1 ) + dzm = float( k1+1 ) - zk + + interp_out = dzm*mdl_data(k1) + dz*mdl_data(k1+1) + return + end if + + end subroutine to_zk2 + +!--------------------------------------------------------------- + + subroutine turbine_area(z1, z2, tdiameter, tarea) + ! This subroutine calculates area of turbine between two vertical levels + ! Input variables : + ! z1 = distance between k level and lower blade tip + ! z2 = distance between k+1 level and lower blade tip + ! wfdensity = wind farm density in m^-2 + ! tdiameter = turbine diameter + ! Output variable : + ! tarea = area of turbine between two levels + implicit none + real, intent(in) :: tdiameter + real, intent(inout) :: z1, z2 + real, intent(out):: tarea + real r, zc1, zc2 + + r = 0.5*tdiameter !r = turbine radius + z1 = r - z1 !distance of kth level from turbine center + z2 = r - z2 !distance of k+1 th level from turbine center + zc1 = abs(z1) + zc2 = abs(z2) + + ! turbine area between z1 and z2 + if(z1 > 0. .and. z2 > 0.) then + tarea = zc1*sqrt(r*r - zc1*zc1) + r*r*asin(zc1/r) - & + zc2*sqrt(r*r - zc2*zc2) - r*r*asin(zc2/r) + else if(z1 < 0. .and. z2 < 0.) then + tarea = zc2*sqrt(r*r - zc2*zc2) + r*r*asin(zc2/r) - & + zc1*sqrt(r*r - zc1*zc1) - r*r*asin(zc1/r) + else + tarea = zc2*sqrt(r*r - zc2*zc2) + r*r*asin(zc2/r) + & + zc1*sqrt(r*r - zc1*zc1) + r*r*asin(zc1/r) + end if + + end subroutine turbine_area + +!--------------------------------------------------------------- + + subroutine dragcof(tkecof, powcof, thrcof, speed, & + turb_ws, turb_tc, turb_pwcof, stdthrcoef, stdthrcoef2, nv) + implicit none + real, intent(in):: speed, stdthrcoef, stdthrcoef2 + integer :: nv + real, dimension(1:nv) :: turb_ws, turb_tc, turb_pwcof + real, intent(out):: tkecof,powcof,thrcof + real :: cispeed, cospeed + + cispeed = turb_ws(1) + cospeed = turb_ws(nv) + + if (speed < cispeed) then + thrcof = stdthrcoef + powcof = 0. + else if (speed > cospeed) then + thrcof = stdthrcoef2 + powcof = 0. + else + call to_zk2(speed, turb_ws(1:nv), turb_tc(1:nv), nv, thrcof) + call to_zk2(speed, turb_ws(1:nv), turb_pwcof(1:nv), nv, powcof) + endif + + ! tke coefficient calculation + tkecof = max(0., thrcof-powcof) !Cri: consider multiplying by 0.5 or so + tkecof = correction_factor * tkecof + !tkecof = 0.25*tkecof ! Yulong + + end subroutine dragcof + +!--------------------------------------------------------------- + +#if defined(mpas) + SUBROUTINE point_in_polyogon(find, px, py, xcell, ycell, dv) + implicit none + + ! dv: side length of hexgon + real, intent(in) :: px, py, xcell, ycell, dv + real :: xx, yy + logical :: find + + xx = abs(px - xcell) + yy = abs(py - ycell) + + find = .false. + if (xx <= dv .and. yy <= sqrt(3.)/2.*dv) then ! in the outer rectangle + if (dv - xx >= yy/sqrt(3.) ) find = .true. + endif + + END SUBROUTINE point_in_polyogon + +!--------------------------------------------------------------- + + ! called in core_atmosphere/physics/mpas_atmphys_init.F + subroutine init_module_wind_jensen_MPAS(dminfo, windfarm_ij, windfarm_deg, & + xcell, ycell, ncells, dc) + implicit none + type(dm_info),intent(in) :: dminfo + integer :: ncells + integer, parameter :: id = 1 + integer :: windfarm_ij + real :: windfarm_deg + real :: dc, dv + real, dimension(ncells), intent(in) :: xcell, ycell !hexgon cell center +! + real :: lat,lon,ts_rx,ts_ry + real :: known_lat, known_lon + integer :: i,j,k,ios, igs, jgs + + real :: x_rot, y_rot, theta, deg, xtb_center, ytb_center, xp, yp + logical :: find + character*256 num,input + + if (windfarm_initialized) return + + windfarm_initialized = .true. + + dv = sqrt(3.)/3.*dc + + if (windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + else if (windfarm_ij == 2) then + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + end if + + nt = 0 + do + read(71, *, iostat=ios) + if (ios /= 0) exit + nt = nt + 1 + end do + close(71) + + allocate (nkind(nt),nval(nt),ival(nt,max_domains),jval(nt,max_domains)) + allocate (xturb(nt,max_domains),yturb(nt,max_domains)) + allocate (hubheight(nt),stc(nt),stc2(nt),area(nt),radius(nt),radius2(nt),diameter(nt),npower(nt)) + allocate(turbws(nt,MAXVALS),turbtc(nt,MAXVALS),turbpw(nt,MAXVALS),turbpwcof(nt,MAXVALS)) + + xturb = -9999. + yturb = -9999. + ival = -9999 + jval = -9999 + turbws = 0. + turbtc = 0. + turbpw = 0. + turbpwcof = 0. + + if (windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + do k = 1, nt + nkind(k) = 1 + read(71,*) xturb(k,id), yturb(k,id) + enddo + close(71) + + !------- set wind farm center coordinate to (0,0) --- + xtb_center = sum(xturb(1:nt,id))/nt + ytb_center = sum(yturb(1:nt,id))/nt + do k = 1, nt + xturb(k,id) = xturb(k,id) - xtb_center + yturb(k,id) = yturb(k,id) - ytb_center + end do + !----------------------------------------------------- + + !------- rotate wind farm ------- + deg = windfarm_deg + do k = 1, nt + !theta = -30./180.*piconst ! d255: 225 - 255 = -30 + + theta = deg/180.*piconst + call coordinate_rotation(x_rot, y_rot, xturb(k,id), yturb(k,id), theta) + xturb(k,id) = x_rot + yturb(k,id) = y_rot + end do + !------------------------------- + + !!-------------- find ix, iy ----------------- + + igs = 10 + jgs = 12 + ival(:,id) = -9999 + jval(:,id) = 1 + DO k = 1, nt + xp = xturb(k,id) + igs*sqrt(3.)/2.*dc + yp = yturb(k,id) + jgs*sqrt(3.)/2.*dc + DO i = 1, ncells + call point_in_polyogon(find, xp, yp, xcell(i), ycell(i), dv) + IF (find) THEN + ival(k,id) = i + EXIT + ENDIF + ENDDO + ENDDO + + !write(*,*) 'MPAS loc0:', ival(:,id) + !call mpas_dmpar_bcast_ints(dminfo, nt, ival(:,id)) + + ! ---- test in one cell --- + !ival(:,id) = ival(1,id) + !write(*,*) 'MPAS loc:', ival(1,id) + write(*,*) 'MPAS loc:' + do k = 1, nt + write(*,*) k, ival(k,id) + end do + !write(*,*) 'xcell:', xcell(1), xcell(ncells) + !write(*,*) 'ycell:', ycell(1), ycell(ncells) + ! ---- test in one cell --- + !!-------------- end find ix, iy ----------- + + do k = 1, nt + write(num,*) nkind(k) + num = adjustl(num) + input = "wind-turbine-"//trim(num)//".tbl" + open(file=trim(input),unit=19,form='formatted',status='old') + read(19,*) nval(k) + read(19,*) hubheight(k), diameter(k), stc(k), npower(k) + + area(k)=piconst/4.*diameter(k)**2 + + do i = 1, nval(k) + read(19,*) turbws(k,i), turbtc(k,i), turbpw(k,i) + turbpwcof(k,i) = turbpw(k,i)*1000./(0.5*1.23*turbws(k,i)**3*area(k)) + end do + + radius(k) = 0.5*diameter(k) + radius2(k) = radius(k)**2 + stc2(k) = turbtc(k,nval(k)) + close (19) + end do + endif + + end subroutine init_module_wind_jensen_MPAS + +!--------------------------------------------------------------- +#else + +subroutine cal_xturb_yturb(lat_nt, lon_nt, wf_id_nt, nt, xturb_nt, yturb_nt) + implicit none + integer :: nt + real(kind=8) :: lat_nt(nt), lon_nt(nt) + integer :: wf_id_nt(nt) + real(kind=8) :: xturb_nt(nt), yturb_nt(nt) + + integer :: ic, wf_id, k, kk, ik, mid_ic, nn + real(kind=8) :: lon_tmp(nt), lat_wf(nt), lon_wf(nt) + real(kind=8) :: lon_center, x, y + real(kind=8) :: x_center, y_center + real(kind=8) :: off_dist = 600000. ! used to seprate wind farms + integer :: num_wf + + num_wf = 1 + + ik = 1 + ic = 1 + wf_id = wf_id_nt(1) + lon_tmp(ic) = lon_nt(1) + lat_wf(ic) = lat_nt(1) + lon_wf(ic) = lon_nt(1) + do k = 2, nt + if (wf_id_nt(k) == wf_id) then + ic = ic + 1 + lon_tmp(ic) = lon_nt(k) + lat_wf(ic) = lat_nt(k) + lon_wf(ic) = lon_nt(k) + else if (wf_id_nt(k) /= wf_id) then + call shell_sort_1D(lon_tmp(1:ic),ic) + mid_ic = ceiling(ic*0.5) + lon_center = lon_tmp(mid_ic) + + x_center = 0. + y_center = 0. + do kk = 1, ic + call latlon_to_xy(lat_wf(kk), lon_wf(kk), lon_center, x, y) + !call latlon_to_xy(lat_wf(kk), lon_wf(kk), real(9.,kind=8), x, y) !Anholt test + xturb_nt(ik) = x + yturb_nt(ik) = y + x_center = x_center + x + y_center = y_center + y + ik = ik + 1 + enddo + + x_center = x_center/ic + y_center = y_center/ic + do kk = ik-ic, ik-1 + xturb_nt(kk) = xturb_nt(kk) - x_center + yturb_nt(kk) = yturb_nt(kk) - y_center + num_wf*off_dist! off set distance for wind farm [m] + enddo + + num_wf = num_wf + 1 + ic = 1 + wf_id = wf_id_nt(k) + lon_tmp(ic) = lon_nt(k) + lat_wf(ic) = lat_nt(k) + lon_wf(ic) = lon_nt(k) + endif + enddo + + call shell_sort_1D(lon_tmp(1:ic),ic) + mid_ic = ceiling(ic*0.5) + lon_center = lon_tmp(mid_ic) + + x_center = 0. + y_center = 0. + do kk = 1, ic + call latlon_to_xy(lat_wf(kk), lon_wf(kk), lon_center, x, y) + !call latlon_to_xy(lat_wf(kk), lon_wf(kk), real(9.,kind=8), x, y) !Anholt test + xturb_nt(ik) = x + yturb_nt(ik) = y + x_center = x_center + x + y_center = y_center + y + ik = ik + 1 + enddo + + x_center = x_center/ic + y_center = y_center/ic + do kk = ik-ic, ik-1 + xturb_nt(kk) = xturb_nt(kk) - x_center + yturb_nt(kk) = yturb_nt(kk) - y_center + num_wf*off_dist ! off set distance for wind farm [m] + enddo + +end subroutine cal_xturb_yturb + +!------------------------------ + +subroutine latlon_to_xy(latitude, longitude, central_lon, easting, northing) +! from https://github.com/Turbo87/utm/blob/master/utm/conversion.py + implicit none + real(kind=8), intent(in) :: latitude, longitude, central_lon + real(kind=8), intent(out) :: easting, northing + + real(kind=8), PARAMETER :: pi = 3.141592653589793 + real(kind=8) :: lat_rad, lat_sin, lat_cos, lat_tan, lat_tan2, lat_tan4 + real(kind=8) :: lon_rad + real(kind=8) :: central_lon_rad, dlon_rad + + real(kind=8), PARAMETER :: K0 = 0.9996 + real(kind=8), PARAMETER :: E = 0.00669438 + real(kind=8), PARAMETER :: R = 6378137. + real(kind=8) :: E2, E3, E_P2, SQRT_E + real(kind=8) :: XE, XE2, XE3, XE4, XE5 + real(kind=8) :: M1, M2, M3, M4, P2, P3, P4, P5 + real(kind=8) :: n, c, a, a2, a3, a4, a5, a6, m + + lat_rad = latitude*pi/180. + lat_sin = sin(lat_rad) + lat_cos = cos(lat_rad) + + lat_tan = lat_sin / lat_cos + lat_tan2 = lat_tan * lat_tan + lat_tan4 = lat_tan2 * lat_tan2 + + lon_rad = longitude*pi/180. + + ! differenct from UTM, set center lon at the wind farm center + central_lon_rad = central_lon*pi/180. + + ! -pi to pi + dlon_rad = mod(lon_rad - central_lon_rad + pi, 2*pi) - pi + + E2 = E * E + E3 = E2 * E + E_P2 = E / (1. - E) + + SQRT_E = sqrt(1. - E) + + XE = (1. - SQRT_E) / (1. + SQRT_E) + XE2 = XE * XE + XE3 = XE2 * XE + XE4 = XE3 * XE + XE5 = XE4 * XE + + M1 = (1. - E / 4. - 3. * E2 / 64. - 5. * E3 / 256.) + M2 = (3. * E / 8. + 3. * E2 / 32. + 45. * E3 / 1024.) + M3 = (15. * E2 / 256. + 45. * E3 / 1024.) + M4 = (35. * E3 / 3072.) + + P2 = (3. / 2. * XE - 27. / 32. * XE3 + 269. / 512. * XE5) + P3 = (21. / 16. * XE2 - 55. / 32. * XE4) + P4 = (151. / 96. * XE3 - 417. / 128. * XE5) + P5 = (1097. / 512. * XE4) + + + n = R / sqrt(1. - E * lat_sin**2) + c = E_P2 * lat_cos**2 + + a = lat_cos * dlon_rad + a2 = a * a + a3 = a2 * a + a4 = a3 * a + a5 = a4 * a + a6 = a5 * a + + m = R * (M1 * lat_rad - & + M2 * sin(2. * lat_rad) + & + M3 * sin(4. * lat_rad) - & + M4 * sin(6. * lat_rad)) + + easting = K0 * n * (a + & + a3 / 6. * (1. - lat_tan2 + c) + & + a5 / 120. * (5. - 18. * lat_tan2 + lat_tan4 + 72. * c - 58. * E_P2)) + 500000. + + northing = K0 * (m + n * lat_tan * & + (a2 / 2. + & + a4 / 24. * (5. - lat_tan2 + 9. * c + 4. * c**2) + & + a6 / 720. * (61. - 58. * lat_tan2 + lat_tan4 + 600. * c - 330. * E_P2))) + +! if (latitude < 0.) northing = northing + 10000000. + +end subroutine latlon_to_xy + +!------------------------------ + +subroutine shell_sort_1D(AA, n) + implicit none + integer :: n, k + real(kind=8), dimension(1:n) :: AA + integer :: i,j + real(kind=8) :: A_tmp + integer :: B_tmp + k=n/2 + do while( k>0 ) + do i=k+1,n + j=i-k + do while( j>0 ) + if ( AA(j) .gt. AA(j+k) ) then + A_tmp = AA(j) + AA(j) = AA(j+k) + AA(j+k) = A_tmp + + j=j-k + else + exit + end if + end do + end do + k=k/2 + end do + +end subroutine shell_sort_1D + + subroutine init_module_wind_mav(id,config_flags,xlong,xlat,windfarm_initialized,dx,& + ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) + USE module_date_time ! must within subroutine, module_date_time.F ../share/ + implicit none + integer :: ims,ime,jms,jme,ids,ide,jds,jde + integer :: its,ite,jts,jte + real :: dx + real, dimension(ims:ime, jms:jme), intent(in) :: xlong,xlat + + type (grid_config_rec_type) :: config_flags + type (proj_info) :: ts_proj + logical :: windfarm_initialized ! WRF + character*256 num,input,message_wind + real :: lat,lon,ts_rx,ts_ry + real :: known_lat, known_lon + integer :: i,j,k,id,ios, igs, jgs + + real :: xgrid(ide), ygrid(jde), tmp + real :: x_rot, y_rot, theta, deg, xtb_center, ytb_center + + logical, external :: wrf_dm_on_monitor + + + !--- local --- + real(kind=8), dimension(:), allocatable :: lat_nt, lon_nt, xturb_nt, yturb_nt + integer, dimension(:), allocatable :: wf_id_nt + !--- local --- + + !--------- + logical :: lexist + CHARACTER (LEN=24) :: date_str + INTEGER:: julyr + INTEGER:: julday + REAL :: gmt + real(kind=8) :: calday + + !IF ( windfarm_initialized) RETURN + + correction_factor = config_flags%windfarm_tke_factor + + ! get turbine number nt + if ( wrf_dm_on_monitor() ) then + if (config_flags%windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + else if (config_flags%windfarm_ij == 2) then + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + end if + + nt = 0 + do + read(71, *, iostat=ios) + if (ios /= 0) exit + nt = nt + 1 + end do + close(71) + end if + + call wrf_dm_bcast_integer(nt,1) + + if (.not. windfarm_initialized) then + allocate (nkind(nt),nval(nt),ival(nt,max_domains),jval(nt,max_domains)) + allocate (xturb(nt,max_domains),yturb(nt,max_domains)) + allocate (hubheight(nt),stc(nt),stc2(nt),area(nt),radius(nt),radius2(nt),diameter(nt),npower(nt)) + allocate(turbws(nt,MAXVALS),turbtc(nt,MAXVALS),turbpw(nt,MAXVALS),turbpwcof(nt,MAXVALS)) + + allocate (xturb_nt(nt),yturb_nt(nt)) + allocate (lat_nt(nt),lon_nt(nt)) + allocate (wf_id_nt(nt)) + + turbws = 0. + turbtc = 0. + turbpw = 0. + turbpwcof = 0. + nkind(:) = 1 + + windfarm_initialized = .true. + end if + + if (.not. allocated(nkind)) allocate(nkind(nt)) + if (.not. allocated(nval)) allocate(nval(nt)) + if (.not. allocated(ival)) allocate(ival(nt,max_domains)) + if (.not. allocated(jval)) allocate(jval(nt,max_domains)) + if (.not. allocated(xturb)) allocate(xturb(nt,max_domains)) + if (.not. allocated(yturb)) allocate(yturb(nt,max_domains)) + if (.not. allocated(hubheight)) allocate(hubheight(nt)) + if (.not. allocated(stc)) allocate(stc(nt)) + if (.not. allocated(stc2)) allocate(stc2(nt)) + if (.not. allocated(area)) allocate(area(nt)) + if (.not. allocated(radius)) allocate(radius(nt)) + if (.not. allocated(radius2)) allocate(radius2(nt)) + if (.not. allocated(diameter)) allocate(diameter(nt)) + if (.not. allocated(npower)) allocate(npower(nt)) + if (.not. allocated(turbws)) allocate(turbws(nt,maxvals)) + if (.not. allocated(turbtc)) allocate(turbtc(nt,maxvals)) + if (.not. allocated(turbpw)) allocate(turbpw(nt,maxvals)) + if (.not. allocated(turbpwcof)) allocate(turbpwcof(nt,maxvals)) + + if (.not. allocated(xturb_nt)) allocate(xturb_nt(nt)) + if (.not. allocated(yturb_nt)) allocate(yturb_nt(nt)) + if (.not. allocated(lat_nt)) allocate(lat_nt(nt)) + if (.not. allocated(lon_nt)) allocate(lon_nt(nt)) + if (.not. allocated(wf_id_nt)) allocate(wf_id_nt(nt)) + + xturb(:,id) = -9999. + yturb(:,id) = -9999. + ival(:,id) = -9999 + jval(:,id) = -9999 + + ! + ! --- find turbine location --- + ! + if ( wrf_dm_on_monitor() ) then + + ! real case, based on lat, lon + if (config_flags%windfarm_ij == 2) then + CALL map_init(ts_proj) + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + + do k = 1, nt + !read(71,*) lat, lon + read(71,*) lat_nt(k), lon_nt(k), wf_id_nt(k), nkind(k) + lat = lat_nt(k) + lon = lon_nt(k) + known_lat = xlat(its,jts) + known_lon = xlong(its,jts) + + ! Mercator + if (config_flags%map_proj == PROJ_MERC) then + call map_set(PROJ_MERC, ts_proj, & + truelat1 = config_flags%truelat1, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + + ! Lambert conformal + else if (config_flags%map_proj == PROJ_LC) then + call map_set(PROJ_LC, ts_proj, & + truelat1 = config_flags%truelat1, & + truelat2 = config_flags%truelat2, & + stdlon = config_flags%stand_lon, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + + ! Polar stereographic + else if (config_flags%map_proj == PROJ_PS) then + call map_set(PROJ_PS, ts_proj, & + truelat1 = config_flags%truelat1, & + stdlon = config_flags%stand_lon, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + end if + + call latlon_to_ij(ts_proj, lat, lon, ts_rx, ts_ry) + + ival(k,id)=nint(ts_rx) + jval(k,id)=nint(ts_ry) +! write(*,*) 'sss', id, k, ts_rx + if (ival(k,id).lt.ids.and.ival(k,id).gt.ide) then + ival(k,id) = -9999 + jval(k,id) = -9999 + end if + + end do + close(71) + + !--- cal turbine locations (x,y in [m]) based on (lat, lon) + call cal_xturb_yturb(lat_nt, lon_nt, wf_id_nt, nt, xturb_nt, yturb_nt) + do k = 1, nt + xturb(k,id) = xturb_nt(k) + yturb(k,id) = yturb_nt(k) + !write(*,*) xturb(k,id), yturb(k,id) + end do + + end if ! windfarm_ij == 2 + + ! ideal case, based on x, y (m) + if (config_flags%windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + do k = 1, nt + read(71,*) xturb(k,id), yturb(k,id), wf_id_nt(k), nkind(k) + !read(71,*) xturb(k,id), yturb(k,id) + ! wf_id_nt(k) = 1 + ! nkind(k) = 1 + enddo + close(71) + + ! reset wind farm center coordinate to (0,0) + xtb_center = sum(xturb(1:nt,id))/nt + ytb_center = sum(yturb(1:nt,id))/nt + do k = 1, nt + xturb(k,id) = xturb(k,id) - xtb_center + yturb(k,id) = yturb(k,id) - ytb_center + end do + + ! rotate wind farm + deg = config_flags%windfarm_deg + do k = 1, nt + !theta = -30./180.*piconst ! d255: 225 - 255 = -30 + theta = deg/180.*piconst + call coordinate_rotation(x_rot, y_rot, xturb(k,id), yturb(k,id), theta) + xturb(k,id) = x_rot + yturb(k,id) = y_rot + end do + + !!-------------- find ix, iy ----------------- + !igs = int(ide/2.5); jgs = int(jde/2.5) ! set wind farm center grid + igs = int(ide/3); jgs = int(jde/3) ! set wind farm right lower coner + + do i = 1, ide + xgrid(i) = (i-1)*dx + end do + do j = 1, jde + ygrid(j) = (j-1)*dx + end do + + do k = 1, nt + tmp = (igs-1)*dx + xturb(k,id) + do i = 1, ide-1 + if (xgrid(i) <= tmp .and. xgrid(i+1) > tmp) then + ival(k,id) = i + exit + end if + end do + + tmp = (jgs-1)*dx + yturb(k,id) + do j = 1, jde-1 + if (ygrid(j) <= tmp .and. ygrid(j+1) > tmp) then + jval(k,id) = j + exit + end if + end do + + ! ---- test in one cell --- + !ival(k,id) = igs + !jval(k,id) = jgs + !ival(k,id) = 12 + !jval(k,id) = 12 + ! ---- test in one cell --- + end do + !!-------------- end find ix, iy ----------- + write(*,*) 'WRF loc:' + do k = 1, nt + write(*,*) k, ival(k,id), jval(k,id) + end do + end if + end if + + ! + ! read turbine info + ! + if ( wrf_dm_on_monitor() ) then + do k = 1, nt + write(num,*) nkind(k) + num = adjustl(num) + input = "wind-turbine-"//trim(num)//".tbl" + open(file=trim(input),unit=19,form='formatted',status='old') + read(19,*) nval(k) + read(19,*) hubheight(k), diameter(k), stc(k), npower(k) + + area(k)=piconst/4.*diameter(k)**2 + + do i = 1, nval(k) + read(19,*) turbws(k,i), turbtc(k,i), turbpw(k,i) + turbpwcof(k,i) = turbpw(k,i)*1000./(0.5*1.23*turbws(k,i)**3*area(k)) + end do + + radius(k) = 0.5*diameter(k) + radius2(k) = radius(k)**2 + stc2(k) = turbtc(k,nval(k)) + close (19) + end do + end if + + call wrf_dm_bcast_integer(nval,nt) + call wrf_dm_bcast_integer(ival,nt*max_domains) + call wrf_dm_bcast_integer(jval,nt*max_domains) + call wrf_dm_bcast_real(xturb,nt*max_domains) + call wrf_dm_bcast_real(yturb,nt*max_domains) + call wrf_dm_bcast_real(hubheight,nt) + call wrf_dm_bcast_real(area,nt) + call wrf_dm_bcast_real(radius,nt) + call wrf_dm_bcast_real(radius2,nt) + call wrf_dm_bcast_real(diameter,nt) + call wrf_dm_bcast_real(stc,nt) + call wrf_dm_bcast_real(stc2,nt) + call wrf_dm_bcast_real(npower,nt) + call wrf_dm_bcast_integer(nkind,nt) + call wrf_dm_bcast_real(turbws,nt*maxvals) + call wrf_dm_bcast_real(turbtc,nt*maxvals) + call wrf_dm_bcast_real(turbpw,nt*maxvals) + call wrf_dm_bcast_real(turbpwcof,nt*maxvals) + + end subroutine init_module_wind_mav + +#endif +END MODULE module_wind_mav diff --git a/phys/physics_mmm/bl_gwdo.F90 b/phys/physics_mmm/bl_gwdo.F90 new file mode 100644 index 0000000000..b314634539 --- /dev/null +++ b/phys/physics_mmm/bl_gwdo.F90 @@ -0,0 +1,649 @@ +!================================================================================================================= + module bl_gwdo + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: bl_gwdo_run, & + bl_gwdo_init, & + bl_gwdo_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_gwdo_init +!!\html\include bl_gwdo_init.html +!! + subroutine bl_gwdo_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_gwdo_init OK' + errflg = 0 + + end subroutine bl_gwdo_init + +!================================================================================================================= +!>\section arg_table_bl_gwdo_finalize +!!\html\include bl_gwdo_finalize.html +!! + subroutine bl_gwdo_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_gwdo_finalize OK' + errflg = 0 + + end subroutine bl_gwdo_finalize + +!================================================================================================================= +!>\section arg_table_bl_gwdo_run +!!\html\include bl_gwdo_run.html +!! + subroutine bl_gwdo_run(sina, cosa, & + rublten,rvblten, & + dtaux3d,dtauy3d, & + dusfcg,dvsfcg, & + uproj, vproj, & + t1, q1, & + prsi, prsl, prslk, zl, & + var, oc1, & + oa2d1, oa2d2, & + oa2d3, oa2d4, & + ol2d1, ol2d2, & + ol2d3, ol2d4, & + g_, cp_, rd_, rv_, fv_, pi_, & + dxmeter, deltim, & + its, ite, kte, kme, & + errmsg, errflg ) +!------------------------------------------------------------------------------- +! +! abstract : +! this code handles the time tendencies of u v due to the effect of +! mountain induced gravity wave drag from sub-grid scale orography. +! this routine not only treats the traditional upper-level wave breaking due +! to mountain variance (alpert 1988), but also the enhanced +! lower-tropospheric wave breaking due to mountain convexity and asymmetry +! (kim and arakawa 1995). thus, in addition to the terrain height data +! in a model grid gox, additional 10-2d topographic statistics files are +! needed, including orographic standard deviation (var), convexity (oc1), +! asymmetry (oa4) and ol (ol4). these data sets are prepared based on the +! 30 sec usgs orography (hong 1999). the current scheme was implmented as in +! choi and hong (2015), which names kim gwdo since it was developed by +! kiaps staffs for kiaps integrated model system (kim). the scheme +! additionally includes the effects of orographic anisotropy and +! flow-blocking drag. +! coded by song-you hong and young-joon kim and implemented by song-you hong +! +! history log : +! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy +! +! references : +! choi and hong (2015), j. geophys. res. +! hong et al. (2008), wea. forecasting +! kim and doyle (2005), q. j. r. meteor. soc. +! kim and arakawa (1995), j. atmos. sci. +! alpet et al. (1988), NWP conference +! hong (1999), NCEP office note 424 +! +! input : +! dudt, dvdt - non-lin tendency for u and v wind component +! uproj, vproj - projection-relative U and V m/sec +! u1, v1 - zonal and meridional wind m/sec at t0-dt +! t1 - temperature deg k at t0-dt +! q1 - mixing ratio at t0-dt +! deltim - time step (s) +! del - positive increment of pressure across layer (pa) +! prslk, zl, prsl, prsi - pressure and height variables +! oa4, ol4, omax, var, oc1 - orographic statistics +! +! output : +! dudt, dvdt - wind tendency due to gwdo +! dtaux2d, dtauy2d - diagnoised orographic gwd +! dusfc, dvsfc - gw stress +! +!------------------------------------------------------------------------------- + implicit none +! + integer, parameter :: kts = 1 + integer , intent(in ) :: its, ite, kte, kme + real(kind=kind_phys) , intent(in ) :: g_, pi_, rd_, rv_, fv_,& + cp_, deltim + real(kind=kind_phys), dimension(its:) , intent(in ) :: dxmeter + real(kind=kind_phys), dimension(its:,:) , intent(inout) :: rublten, rvblten + real(kind=kind_phys), dimension(its:,:) , intent( out) :: dtaux3d, dtauy3d + real(kind=kind_phys), dimension(its:) , intent( out) :: dusfcg, dvsfcg + real(kind=kind_phys), dimension(its:) , intent(in ) :: sina, cosa + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: uproj, vproj + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: t1, q1, prslk, zl +! + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsl + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsi +! + real(kind=kind_phys), dimension(its:) , intent(in ) :: var, oc1, & + oa2d1, oa2d2, oa2d3, oa2d4, & + ol2d1, ol2d2, ol2d3, ol2d4 + character(len=*) , intent( out) :: errmsg + integer , intent( out) :: errflg +! + real(kind=kind_phys), parameter :: ric = 0.25 ! critical richardson number + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 +! +! local variables +! + integer :: kpblmax + integer :: latd,lond + integer :: i,k,lcap,lcapp1,nwd,idir, & + klcap,kp1,ikount,kk +! + real(kind=kind_phys) :: fdir,cs,rcsks, & + wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & + wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & + temv,dtaux,dtauy +! + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dudt, dvdt + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dtaux2d, dtauy2d + real(kind=kind_phys), dimension(its:ite) :: dusfc, dvsfc + logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 + real(kind=kind_phys), dimension(its:ite) :: coefm +! + real(kind=kind_phys), dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & + ulow, rulow, bnv, oa, ol, rhobar, & + dtfac, brvf, xlinv, delks,delks1, & + zlowtop,cleff + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taup + real(kind=kind_phys), dimension(its:ite,kts:kte-1) :: velco + real(kind=kind_phys), dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj + real(kind=kind_phys), dimension(its:ite,kts:kte) :: del + real(kind=kind_phys), dimension(its:ite,kts:kte) :: u1, v1 + real(kind=kind_phys), dimension(its:ite,4) :: oa4, ol4 +! + integer, dimension(its:ite) :: kbl, klowtop + integer, parameter :: mdir=8 + integer, dimension(mdir) :: nwdir + data nwdir/6,7,5,8,2,3,1,4/ +! +! variables for flow-blocking drag +! + real(kind=kind_phys), parameter :: frmax = 10. + real(kind=kind_phys), parameter :: olmin = 1.0e-5 + real(kind=kind_phys), parameter :: odmin = 0.1 + real(kind=kind_phys), parameter :: odmax = 10. +! + real(kind=kind_phys) :: fbdcd + real(kind=kind_phys) :: zblk, tautem + real(kind=kind_phys) :: fbdpe, fbdke + real(kind=kind_phys), dimension(its:ite) :: delx, dely + real(kind=kind_phys), dimension(its:ite,4) :: dxy4, dxy4p + real(kind=kind_phys), dimension(4) :: ol4p + real(kind=kind_phys), dimension(its:ite) :: dxy, dxyp, olp, od + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taufb +! + integer, dimension(its:ite) :: komax + integer :: kblk +!------------------------------------------------------------------------------- +! +! constants +! + lcap = kte + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi_) +! +! initialize CCPP error flag and message +! + errmsg = '' + errflg = 0 +! +! calculate length of grid for flow-blocking drag +! + delx(its:ite) = dxmeter(its:ite) + dely(its:ite) = dxmeter(its:ite) + dxy4(its:ite,1) = delx(its:ite) + dxy4(its:ite,2) = dely(its:ite) + dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) + dxy4(its:ite,4) = dxy4(its:ite,3) + dxy4p(its:ite,1) = dxy4(its:ite,2) + dxy4p(its:ite,2) = dxy4(its:ite,1) + dxy4p(its:ite,3) = dxy4(its:ite,4) + dxy4p(its:ite,4) = dxy4(its:ite,3) +! + cleff(its:ite) = dxmeter(its:ite) +! +! initialize arrays, array syntax is OK for OpenMP since these are local +! + ldrag = .false. ; icrilv = .false. ; flag = .true. +! + klowtop = 0 ; kbl = 0 +! + dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. + ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. + oa = 0. ; ol = 0. ; taub = 0. +! + usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. + taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. +! + dtfac = 1.0 ; xlinv = 1.0/xl +! + komax = 0 + taufb = 0.0 +! + do k = kts,kte + do i = its,ite + vtj(i,k) = t1(i,k) * (1.+fv_*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + + ! Density (kg/m^3) + + rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) + + ! Delta p (positive) between interfaces levels (Pa) + + del(i,k) = prsi(i,k) - prsi(i,k+1) + + ! Earth-relative zonal and meridional winds (m/s) + + u1(i,k) = uproj(i,k)*cosa(i) - vproj(i,k)*sina(i) + v1(i,k) = uproj(i,k)*sina(i) + vproj(i,k)*cosa(i) + + enddo + enddo + +! + do i = its,ite + zlowtop(i) = 2. * var(i) + enddo +! + do i = its,ite + kloop1(i) = .true. + enddo +! + do k = kts+1,kte + do i = its,ite + if(zlowtop(i) .gt. 0.) then + if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + endif + enddo + enddo +! + kpblmax = kte + do i = its,ite + kbl(i) = klowtop(i) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + komax(:) = kbl(:) +! + do i = its,ite + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,ite + if (k.lt.kbl(i)) then + rcsks = del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho mean + endif + enddo + enddo +! +! figure out low-level horizontal wind direction +! +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! + do i = its,ite + oa4(i,1) = oa2d1(i) + oa4(i,2) = oa2d2(i) + oa4(i,3) = oa2d3(i) + oa4(i,4) = oa2d4(i) + ol4(i,1) = ol2d1(i) + ol4(i,2) = ol2d2(i) + ol4(i,3) = ol2d3(i) + ol4(i,4) = ol2d4(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(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) +! +! compute orographic width along (ol) and perpendicular (olp) the wind direction +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +! compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +! compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(i,MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) + enddo +! +! saving richardson number in usqj for migwdi +! + do k = kts,kte-1 + do i = its,ite + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g_*(g_/cp_+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + enddo + enddo +! +! compute the "low level" or 1/3 wind magnitude (m/s) +! + do i = its,ite + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) + rulow(i) = 1./ulow(i) + enddo +! + do k = kts,kte-1 + do i = its,ite + velco(i,k) = 0.5 * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then + velco(i,k) = veleps + endif + enddo + enddo +! +! no drag when critical level in the base layer +! + do i = its,ite + ldrag(i) = velco(i,1).le.0. + enddo +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. + enddo + enddo +! +! the low level weighted average ri is stored in usqj(1,1; im) +! the low level weighted average n**2 is stored in bnv2(1,1; im) +! this is called bnvl2 in phy_gwd_alpert_sub not bnv2 +! rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + do i = its,ite + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) + enddo +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo + enddo +! + do i = its,ite + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + enddo +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo + enddo +! + do i = its,ite + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) + endif + enddo +! +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt +! + do i = its,ite + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) + xlinv(i) = coefm(i) / cleff(i) + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + taub(i) = xlinv(i) * rhobar(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + enddo +! +! now compute vertical structure of the stress. +! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo +! + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + .or. (velco(i,k) .le. 0.0) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo +! + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then + temv = 1.0 / velco(i,k) + tem1 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(i,k))*brvf(i)*velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv +! +! rim is the minimum-richardson number by shutts (1985) +! + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) +! +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions +! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo +! + if (lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + do i = its,ite + if (.not.ldrag(i)) then +! +! determine the height of flow-blocking layer +! + kblk = 0 + fbdpe = 0.0 + fbdke = 0.0 + do k = kte, kpblmin, -1 + if (kblk.eq.0 .and. k.le.kbl(i)) then + fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & + *del(i,k)/g_/rho(i,k) + fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) +! +! apply flow-blocking drag when fbdpe >= fbdke +! + if (fbdpe.ge.fbdke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + if (kblk.ne.0) then +! +! compute flow-blocking stress +! + fbdcd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter(i)**2*fbdcd*dxyp(i) & + *olp(i)*zblk*ulow(i)**2 + tautem = taufb(i,kts)/real(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +! sum orographic GW stress and flow-blocking stress +! + taup(i,:) = taup(i,:) + taufb(i,:) + endif + endif + enddo +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,kte + do i = its,ite + taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * g_ / del(i,k) + enddo + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,ite + if (k .le. kbl(i)) then + if (taud(i,k).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k)/(deltim*taud(i,k)))) + endif + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + enddo +! + do k = kts,kte + do i = its,ite + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) + dtaux2d(i,k) = dtaux + dtauy2d(i,k) = dtauy + dudt(i,k) = dtaux + dvdt(i,k) = dtauy + dusfc(i) = dusfc(i) + dtaux * del(i,k) + dvsfc(i) = dvsfc(i) + dtauy * del(i,k) + enddo + enddo +! + do i = its,ite + dusfc(i) = (-1./g_) * dusfc(i) + dvsfc(i) = (-1./g_) * dvsfc(i) + enddo +! +! rotate tendencies from zonal/meridional back to model grid +! + do k = kts,kte + do i = its,ite + rublten(i,k) = rublten(i,k)+dudt(i,k)*cosa(i) + dvdt(i,k)*sina(i) + rvblten(i,k) = rvblten(i,k)-dudt(i,k)*sina(i) + dvdt(i,k)*cosa(i) + dtaux3d(i,k) = dtaux2d(i,k)*cosa(i) + dtauy2d(i,k)*sina(i) + dtauy3d(i,k) =-dtaux2d(i,k)*sina(i) + dtauy2d(i,k)*cosa(i) + enddo + enddo + do i = its,ite + dusfcg(i) = dusfc(i)*cosa(i) + dvsfc(i)*sina(i) + dvsfcg(i) =-dusfc(i)*sina(i) + dvsfc(i)*cosa(i) + enddo + return + end subroutine bl_gwdo_run + + +!================================================================================================================= + end module bl_gwdo +!================================================================================================================= + diff --git a/phys/physics_mmm/bl_ysu.F90 b/phys/physics_mmm/bl_ysu.F90 new file mode 100644 index 0000000000..710fa65cf9 --- /dev/null +++ b/phys/physics_mmm/bl_ysu.F90 @@ -0,0 +1,1696 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 +!================================================================================================================= + module bl_ysu + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: bl_ysu_run, & + bl_ysu_init, & + bl_ysu_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_ysu_init +!!\html\include bl_ysu_init.html +!! + subroutine bl_ysu_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_ysu_init OK' + errflg = 0 + + end subroutine bl_ysu_init + +!================================================================================================================= +!>\section arg_table_bl_ysu_finalize +!!\html\include bl_ysu_finalize.html +!! + subroutine bl_ysu_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_ysu_finalize OK' + errflg = 0 + + end subroutine bl_ysu_finalize + +!================================================================================================================= +!>\section arg_table_bl_ysu_run +!!\html\include bl_ysu_run.html +!! + subroutine bl_ysu_run(ux,vx,tx,qvx,qcx,qix,nmix,qmix,p2d,p2di,pi2d, & + f_qc,f_qi, & + utnp,vtnp,ttnp,qvtnp,qctnp,qitnp,qmixtnp, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w2d,psfcpa, & + znt,ust,hpbl,dusfc,dvsfc,dtsfc,dqsfc,psim,psih, & + xland,hfx,qfx,wspd,br, & + dt,kpbl1d, & + exch_hx,exch_mx, & + wstar,delta, & + u10,v10, & + uox,vox, & + rthraten, & + ysu_topdown_pblmix, & + ctopo,ctopo2, & + a_u,a_v,a_t,a_q,a_e, & + b_u,b_v,b_t,b_q,b_e, & + sfk,vlk,dlu,dlg,frcurb, & + flag_bep, & + its,ite,kte,kme, & + errmsg,errflg & + ) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! this code is a revised vertical diffusion package ("ysupbl") +! with a nonlocal turbulent mixing in the pbl after "mrfpbl". +! the ysupbl (hong et al. 2006) is based on the study of noh +! et al.(2003) and accumulated realism of the behavior of the +! troen and mahrt (1986) concept implemented by hong and pan(1996). +! the major ingredient of the ysupbl is the inclusion of an explicit +! treatment of the entrainment processes at the entrainment layer. +! this routine uses an implicit approach for vertical flux +! divergence and does not require "miter" timesteps. +! it includes vertical diffusion in the stable atmosphere +! and moist vertical diffusion in clouds. +! +! mrfpbl: +! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) +! fall 1996 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! further modifications : +! an enhanced stable layer mixing, april 2008 +! ==> increase pbl height when sfc is stable (hong 2010) +! pressure-level diffusion, april 2009 +! ==> negligible differences +! implicit forcing for momentum with clean up, july 2009 +! ==> prevents model blowup when sfc layer is too low +! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 +! ==> prevents model blowup when delz is extremely large +! revised prandtl number at surface, peggy lemone, feb 2010 +! ==> increase kh, decrease mixing due to counter-gradient term +! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 +! ==> reduce the thermal strength when z1 < 0.1 h +! revised prandtl number for free convection, dudhia, mar 2012 +! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced +! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 +! ==> weaker mixing when stable, and les resolution in vertical +! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 +! ==> consider thermal z0 when differs from mechanical z0 +! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 +! ==> wscale becomes small with height, and less mixing in stable bl +! revision in background diffusion (kzo), jan 2016 +! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for +! internal wave mixing of large et al. (1994), songyou hong, feb 2016 +! ==> alleviate superious excessive mixing when delz is large +! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 +! +! references: +! +! hendricks, knievel, and wang (2020), j. appl. meteor. clim. +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! hong and pan (1996), mon. wea. rev. +! noh, chun, hong, and raasch (2003), boundary layer met. +! troen and mahrt (1986), boundary layer met. +! +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + integer,parameter :: imvdif = 1 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: kts=1, kms=1 +! + integer, intent(in ) :: its,ite,kte,kme + + logical, intent(in) :: ysu_topdown_pblmix +! + integer, intent(in) :: nmix +! + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv +! + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman +! + logical, intent(in ) :: f_qc, f_qi +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in) :: dz8w2d, & + pi2d +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: tx, & + qvx, & + qcx, & + qix +! + real(kind=kind_phys), dimension( its:,:,: ) , & + intent(in ) :: qmix +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(out ) :: utnp, & + vtnp, & + ttnp, & + qvtnp, & + qctnp, & + qitnp +! + real(kind=kind_phys), dimension( its:,:,: ) , & + intent(out ) :: qmixtnp +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: p2di +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: p2d +! + real(kind=kind_phys), dimension( its: ) , & + intent(out ) :: hpbl +! + real(kind=kind_phys), dimension( its: ) , & + intent(out ), optional :: dusfc, & + dvsfc, & + dtsfc, & + dqsfc +! + real(kind=kind_phys), dimension( its: ) , & + intent(in ) :: ust, & + znt + real(kind=kind_phys), dimension( its: ) , & + intent(in ) :: xland, & + hfx, & + qfx +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: wspd + real(kind=kind_phys), dimension( its: ), intent(in ) :: br +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: psim, & + psih +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: psfcpa + integer, dimension( its: ), intent(out ) :: kpbl1d +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: ux, & + vx, & + rthraten + real(kind=kind_phys), dimension( its: ) , & + optional , & + intent(in ) :: ctopo, & + ctopo2 +! + logical, intent(in ) :: flag_bep + real(kind=kind_phys), dimension( its:,: ) , & + optional , & + intent(in ) :: a_u, & + a_v, & + a_t, & + a_q, & + a_e, & + b_u, & + b_v, & + b_t, & + b_q, & + b_e, & + sfk, & + vlk, & + dlu, & + dlg + real(kind=kind_phys), dimension( its: ) , & + optional , & + intent(in ) :: frcurb +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! +! local vars +! + real(kind=kind_phys), dimension( its:ite ) :: hol + real(kind=kind_phys), dimension( its:ite, kms:kme ) :: zq +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( its:ite ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzh,xkzm,xkzq, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + zfac, & + rhox2, & + hgamt2, & + ad1,adm,adv +! +!jdf added exch_hx +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(out ) :: exch_hx, & + exch_mx +! + real(kind=kind_phys), dimension( its:ite ) , & + intent(inout) :: u10, & + v10 + real(kind=kind_phys), dimension( its:ite ), optional , & + intent(in ) :: uox, & + vox + real(kind=kind_phys), dimension( its:ite ) :: uoxl, & + voxl + real(kind=kind_phys), dimension( its:ite ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( its:ite, kts:kte) :: r3,f3 + integer, dimension( its:ite ) :: kpbl,kpblold +! + logical, dimension( its:ite ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc +! + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( its:ite ), intent(out) :: wstar, & + delta + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: qcxl, & + qixl + real(kind=kind_phys), dimension( its:ite ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv +!topo-corr + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: fric, & + tke_ysu,& + el_ysu,& + shear_ysu,& + buoy_ysu + real(kind=kind_phys), dimension( its:ite) :: pblh_ysu,& + vconvfx +! + real(kind=kind_phys) :: bepswitch + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + a_u2d,a_v2d,a_t2d,a_q2d,a_e2d,b_u2d,b_v2d,b_t2d,b_q2d,b_e2d, & + sfk2d,vlk2d,dlu2d,dlg2d + real(kind=kind_phys), dimension( its:ite ) :: & + frc_urb1d + + real(kind=kind_phys), dimension( kts:kte ) :: thvx_1d,tke_1d,dzq_1d + real(kind=kind_phys), dimension( kts:kte+1) :: zq_1d + +! +!------------------------------------------------------------------------------- +! + klpbl = kte +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! +! k-start index for tracer diffusion +! + if(f_qc) then + do k = kts,kte + do i = its,ite + qcxl(i,k) = qcx(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qcxl(i,k) = 0. + enddo + enddo + endif +! + if(f_qi) then + do k = kts,kte + do i = its,ite + qixl(i,k) = qix(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qixl(i,k) = 0. + enddo + enddo + endif +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qcxl(i,k)/cp-2.834E6*qixl(i,k)/cp)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qvx(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + if ( present(uox) .and. present(vox) ) then + do i =its,ite + uoxl(i) = uox(i) + voxl(i) = vox(i) + enddo + else + do i =its,ite + uoxl(i) = 0 + voxl(i) = 0 + enddo + endif +! + do i = its,ite + tvcon = (1.+ep1*qvx(i,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + enddo +! + if(present(a_u) .and. present(a_v) .and. present(a_t) .and. & + present(a_q) .and. present(a_t) .and. present(a_e) .and. & + present(b_u) .and. present(b_v) .and. present(b_t) .and. & + present(b_q) .and. present(b_e) .and. present(dlg) .and. & + present(dlu) .and. present(sfk) .and. present(vlk) .and. & + present(frcurb) .and. flag_bep) then + + bepswitch=1.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = a_u(i,k) + a_v2d(i,k) = a_v(i,k) + a_t2d(i,k) = a_t(i,k) + a_q2d(i,k) = a_q(i,k) + a_e2d(i,k) = a_e(i,k) + b_u2d(i,k) = b_u(i,k) + b_v2d(i,k) = b_v(i,k) + b_t2d(i,k) = b_t(i,k) + b_q2d(i,k) = b_q(i,k) + b_e2d(i,k) = b_e(i,k) + dlg2d(i,k) = dlg(i,k) + dlu2d(i,k) = dlu(i,k) + vlk2d(i,k) = vlk(i,k) + sfk2d(i,k) = sfk(i,k) + enddo + enddo + do i = its, ite + frc_urb1d(i) = frcurb(i) + enddo + else + bepswitch=0.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = 0.0 + a_v2d(i,k) = 0.0 + a_t2d(i,k) = 0.0 + a_q2d(i,k) = 0.0 + a_e2d(i,k) = 0.0 + b_u2d(i,k) = 0.0 + b_v2d(i,k) = 0.0 + b_t2d(i,k) = 0.0 + b_q2d(i,k) = 0.0 + b_e2d(i,k) = 0.0 + dlg2d(i,k) = 0.0 + dlu2d(i,k) = 0.0 + vlk2d(i,k) = 1.0 + sfk2d(i,k) = 1.0 + enddo + enddo + do i = its, ite + frc_urb1d(i) = 0.0 + enddo + endif +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = its,ite + zq(i,1) = 0. + enddo +! + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz8w2d(i,k)+zq(i,k) + tvcon = (1.+ep1*qvx(i,k)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) + enddo + enddo +! + do k = kts,kte + do i = its,ite + za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + enddo + enddo +! + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte + do i = its,ite + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo +! +!-----initialize output and local exchange coefficents: + do k = kts,kte + do i = its,ite + exch_hx(i,k) = 0. + exch_mx(i,k) = 0. + xkzh(i,k) = 0. + xkzhl(i,k) = 0. + xkzm(i,k) = 0. + xkzml(i,k) = 0. + xkzq(i,k) = 0. + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt( (ux(i,1)-uoxl(i))*(ux(i,1)-uoxl(i)) + (vx(i,1)-voxl(i))*(vx(i,1)-voxl(i)) )+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + wstar3_2(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo + do k = kts,klpbl-1 + do i = its,ite + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = its,ite + if(present(dusfc)) dusfc(i) = 0. + if(present(dvsfc)) dvsfc(i) = 0. + if(present(dtsfc)) dtsfc(i) = 0. + if(present(dqsfc)) dqsfc(i) = 0. + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix)then + do i = its,ite + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), kte-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! stable boundary layer +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = its,ite + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = its,ite + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + cloudflg(i)=.false. + if(pblflg(i)) then + k = kpbl(i) - 1 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and.ysu_topdown_pblmix)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qvx(i,k)+qcxl(i,k))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qvx(i,k)+qcxl(i,k))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qvx(i,k+2)+qcxl(i,k+2))) & + - (thlix(i,k) + thx(i,k) *ep1*(qvx(i,k) +qcxl(i,k))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p2di(i,kk)-p2di(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qvx(i,k+1)-qvx(i,k),0.0) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1)then + if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and. & + (qcxl(i,k+1)+qixl(i,k+1)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qvx(i,k)+qvx(i,k+1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_hx(i,k+1) = xkzh(i,k) + enddo + enddo +! +! add bep/bep+bem forcing for heat if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttend + if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt + ttnp(i,k) = ttend + if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) +#endif + enddo + enddo +! + +!--- compute tridiagonal matrix elements for water vapor, cloud water, and cloud ice: + !--- initialization of k-coefficient above the PBL. + do i = its,ite + do k = kts,kte-1 + if(k .ge. kpbl(i)) xkzq(i,k) = xkzh(i,k) + enddo + enddo + + !--- water vapor: + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + r1(i,k) = 0. + enddo + + k = 1 + ad(i,1) = 1. + f1(i,1) = qvx(i,1)+(1.0-bepswitch)*qfx(i)*g/del(i,1)*dt2 + + do k = kts,kte-1 + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzq + f1(i,k+1) = qvx(i,k+1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f1(i,k+1) = qvx(i,k+1) + else + f1(i,k+1) = qvx(i,k+1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo +! +! add bep/bep+bem forcing for water vapor if flag_bep=.true. +! + do k = kts,kte + adv(i,k) = ad(i,k) - a_q2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_q2d(i,k)*dt2 + enddo + + do k = kts,kte + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,adv,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qvx(i,k))*rdt + qvtnp(i,k) = qtend + if(present(dqsfc)) dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo + + !--- cloud water: + if(f_qc) then + do i = its,ite + do k = kts,kte + f1(i,k) = qcxl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qcxl(i,k))*rdt + qctnp(i,k) = qtend + enddo + enddo + endif + + !--- cloud ice: + if(f_qi) then + do i = its,ite + do k = kts,kte + f1(i,k) = qixl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qixl(i,k))*rdt + qitnp(i,k) = qtend + enddo + enddo + endif + + !--- chemical species and/or passive tracers, meaning all variables that we want to + ! be vertically-mixed, if nmix=0 (number of tracers) then the loop is skipped + do n = 1, nmix + do i = its,ite + do k = kts,kte + f1(i,k) = qmix(i,k,n) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qmix(i,k,n))*rdt + qmixtnp(i,k,n) = qtend + enddo + enddo + enddo + +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! +! paj: ctopo=1 if topo_wind=0 (default) +!raquel---paj tke code (could be replaced with shin-hong tke in future + do i = its,ite + do k= kts, kte-1 + shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & + + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) + buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) + + zk = karman*zq(i,k+1) + !over pbl + if (k.ge.kpbl(i)) then + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + else + !in pbl + rlamdz = 150.0 + endif + el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) + tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) + !q2 when q3 positive + if(tke_ysu(i,k).le.0) then + tke_ysu(i,k)=0.0 + else + tke_ysu(i,k)=(tke_ysu(i,k))**0.66 + endif + enddo + !Hybrid pblh of MYNN + !tke is q2 +! CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& +! & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) + do k = kts,kte + thvx_1d(k) = thvx(i,k) + tke_1d(k) = tke_ysu(i,k) + zq_1d(k) = zq(i,k) + dzq_1d(k) = dzq(i,k) + enddo + zq_1d(kte+1) = zq(i,kte+1) + call get_pblh(kts,kte,pblh_ysu(i),thvx_1d,tke_1d,zq_1d,dzq_1d,xland(i)) + +!--- end of paj tke +! compute vconv +! Use Beljaars over land + if (xland(i).lt.1.5) then + fluxc = max(sflux(i),0.0) + vconvc=1. + VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 + else +! for water there is no topo effect so vconv not needed + VCONV = 0. + endif + vconvfx(i) = vconv +!raquel +!ctopo stability correction + fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + if(present(ctopo)) then + vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) + vconvlim = min(vconvnew,1.0) + ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) + ad(i,1) = ad(i,1) - bepswitch*frc_urb1d(i)* & + (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) +! ad(i,1) = 1.+(1.-bepswitch*frc_urb1d(i))* & +! (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) + else + ad(i,1) = 1.+fric(i,1) + endif + f1(i,1) = ux(i,1)+uoxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + f2(i,1) = vx(i,1)+voxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_mx(i,k+1) = xkzm(i,k) + enddo + enddo +! +! add bep/bep+bem forcing for momentum if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad1(i,k) = ad(i,k) + end do + end do + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 + ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 + f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi2n(al,ad,ad1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utend + vtnp(i,k) = vtend + if(present(dusfc)) dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + if(present(dvsfc)) dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! +! paj: ctopo2=1 if topo_wind=0 (default) +! + do i = its,ite + if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM + u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) + v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) + endif !mchen + enddo +! +!---- end of vertical diffusion +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! + errmsg = 'bl_ysu_run OK' + errflg = 0 +! + end subroutine bl_ysu_run + +!================================================================================================================= + subroutine tridi2n(cl,cm,cm1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + cm1, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm1(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo + + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm1(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm1(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi2n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: au, & + cm, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 + + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: aul + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,ite + do k = kts,kte + aul(i,k) = 0. + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + aul(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*aul(i,k-1)) + aul(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*aul(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-aul(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu + +!================================================================================================================= + subroutine get_pblh(kts,kte,zi,thetav1d,qke1d,zw1d,dz1d,landsea) +! Copied from MYNN PBL + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + integer,intent(in) :: kts,kte + real(kind=kind_phys), intent(out) :: zi + real(kind=kind_phys), intent(in) :: landsea + real(kind=kind_phys), dimension(kts:kte), intent(in) :: thetav1d, qke1d, dz1d + real(kind=kind_phys), dimension(kts:kte+1), intent(in) :: zw1d + !local vars + real(kind=kind_phys) :: pblh_tke,qtke,qtkem1,wt,maxqke,tkeeps,minthv + real(kind=kind_phys) :: delt_thv !delta theta-v; dependent on land/sea point + real(kind=kind_phys), parameter :: sbl_lim = 200. !theta-v pbl lower limit of trust (m). + real(kind=kind_phys), parameter :: sbl_damp = 400. !damping range for averaging with tke-based pblh (m). + integer :: i,j,k,kthv,ktke + + !find max tke and min thetav in the lowest 500 m + k = kts+1 + kthv = 1 + ktke = 1 + maxqke = 0. + minthv = 9.e9 + + do while (zw1d(k) .le. 500.) + qtke =max(qke1d(k),0.) ! maximum qke + if (maxqke < qtke) then + maxqke = qtke + ktke = k + endif + if (minthv > thetav1d(k)) then + minthv = thetav1d(k) + kthv = k + endif + k = k+1 + enddo + !tkeeps = maxtke/20. = maxqke/40. + tkeeps = maxqke/40. + tkeeps = max(tkeeps,0.025) + tkeeps = min(tkeeps,0.25) + + !find thetav-based pblh (best for daytime). + zi=0. + k = kthv+1 + if((landsea-1.5).ge.0)then + ! water + delt_thv = 0.75 + else + ! land + delt_thv = 1.5 + endif + + zi=0. + k = kthv+1 + do while (zi .eq. 0.) + if (thetav1d(k) .ge. (minthv + delt_thv))then + zi = zw1d(k) - dz1d(k-1)* & + & min((thetav1d(k)-(minthv + delt_thv))/max(thetav1d(k)-thetav1d(k-1),1e-6),1.0) + endif + k = k+1 + if (k .eq. kte-1) zi = zw1d(kts+1) !exit safeguard + enddo + + !print*,"in get_pblh:",thsfc,zi + !for stable boundary layers, use tke method to complement the + !thetav-based definition (when the theta-v based pblh is below ~0.5 km). + !the tanh weighting function will make the tke-based definition negligible + !when the theta-v-based definition is above ~1 km. + !find tke-based pblh (best for nocturnal/stable conditions). + + pblh_tke=0. + k = ktke+1 + do while (pblh_tke .eq. 0.) + !qke can be negative (if ckmod == 0)... make tke non-negative. + qtke =max(qke1d(k)/2.,0.) ! maximum tke + qtkem1=max(qke1d(k-1)/2.,0.) + if (qtke .le. tkeeps) then + pblh_tke = zw1d(k) - dz1d(k-1)* & + & min((tkeeps-qtke)/max(qtkem1-qtke, 1e-6), 1.0) + !in case of near zero tke, set pblh = lowest level. + pblh_tke = max(pblh_tke,zw1d(kts+1)) + !print *,"pblh_tke:",i,j,pblh_tke, qke1d(k)/2., zw1d(kts+1) + endif + k = k+1 + if (k .eq. kte-1) pblh_tke = zw1d(kts+1) !exit safeguard + enddo + + !blend the two pblh types here: + + wt=.5*tanh((zi - sbl_lim)/sbl_damp) + .5 + zi=pblh_tke*(1.-wt) + zi*wt + + end subroutine get_pblh + +!================================================================================================================= + end module bl_ysu +!================================================================================================================= diff --git a/phys/physics_mmm/cu_ntiedtke.F90 b/phys/physics_mmm/cu_ntiedtke.F90 new file mode 100644 index 0000000000..d91c9a72df --- /dev/null +++ b/phys/physics_mmm/cu_ntiedtke.F90 @@ -0,0 +1,3585 @@ +!================================================================================================================= + module cu_ntiedtke_common + use ccpp_kind_types,only: kind_phys + + + implicit none + save + + real(kind=kind_phys):: alf + real(kind=kind_phys):: als + real(kind=kind_phys):: alv + real(kind=kind_phys):: cpd + real(kind=kind_phys):: g + real(kind=kind_phys):: rd + real(kind=kind_phys):: rv + + real(kind=kind_phys),parameter:: t13 = 1.0/3.0 + real(kind=kind_phys),parameter:: tmelt = 273.16 + real(kind=kind_phys),parameter:: c1es = 610.78 + real(kind=kind_phys),parameter:: c3les = 17.2693882 + real(kind=kind_phys),parameter:: c3ies = 21.875 + real(kind=kind_phys),parameter:: c4les = 35.86 + real(kind=kind_phys),parameter:: c4ies = 7.66 + + real(kind=kind_phys),parameter:: rtwat = tmelt + real(kind=kind_phys),parameter:: rtber = tmelt-5. + real(kind=kind_phys),parameter:: rtice = tmelt-23. + + integer,parameter:: momtrans = 2 + real(kind=kind_phys),parameter:: entrdd = 2.0e-4 + real(kind=kind_phys),parameter:: cmfcmax = 1.0 + real(kind=kind_phys),parameter:: cmfcmin = 1.e-10 + real(kind=kind_phys),parameter:: cmfdeps = 0.30 + real(kind=kind_phys),parameter:: zdnoprc = 2.0e4 + real(kind=kind_phys),parameter:: cprcon = 1.4e-3 + real(kind=kind_phys),parameter:: pgcoef = 0.7 + + real(kind=kind_phys):: rcpd + real(kind=kind_phys):: c2es + real(kind=kind_phys):: c5les + real(kind=kind_phys):: c5ies + real(kind=kind_phys):: r5alvcp + real(kind=kind_phys):: r5alscp + real(kind=kind_phys):: ralvdcp + real(kind=kind_phys):: ralsdcp + real(kind=kind_phys):: ralfdcp + real(kind=kind_phys):: vtmpc1 + real(kind=kind_phys):: zrg + + logical,parameter:: nonequil = .true. + logical,parameter:: lmfpen = .true. + logical,parameter:: lmfmid = .true. + logical,parameter:: lmfscv = .true. + logical,parameter:: lmfdd = .true. + logical,parameter:: lmfdudv = .true. + + +!================================================================================================================= + end module cu_ntiedtke_common +!================================================================================================================= + + module cu_ntiedtke + use ccpp_kind_types,only: kind_phys + use cu_ntiedtke_common + + + implicit none + private + public:: cu_ntiedtke_run, & + cu_ntiedtke_init, & + cu_ntiedtke_finalize + + + contains + + +!================================================================================================================= + subroutine cu_ntiedtke_init(con_cp,con_rd,con_rv,con_xlv,con_xls,con_xlf,con_grav,errmsg,errflg) +!================================================================================================================= + +!input arguments: + real(kind=kind_phys),intent(in):: & + con_cp, & + con_rd, & + con_rv, & + con_xlv, & + con_xls, & + con_xlf, & + con_grav + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + alf = con_xlf + als = con_xls + alv = con_xlv + cpd = con_cp + g = con_grav + rd = con_rd + rv = con_rv + + rcpd = 1.0/con_cp + c2es = c1es*con_rd/con_rv + c5les = c3les*(tmelt-c4les) + c5ies = c3ies*(tmelt-c4ies) + r5alvcp = c5les*con_xlv*rcpd + r5alscp = c5ies*con_xls*rcpd + ralvdcp = con_xlv*rcpd + ralsdcp = con_xls*rcpd + ralfdcp = con_xlf*rcpd + vtmpc1 = con_rv/con_rd-1.0 + zrg = 1.0/con_grav + + errmsg = 'cu_ntiedtke_init OK' + errflg = 0 + + end subroutine cu_ntiedtke_init + +!================================================================================================================= + subroutine cu_ntiedtke_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'cu_ntiedtke_finalize OK' + errflg = 0 + + end subroutine cu_ntiedtke_finalize + +!================================================================================================================= +! level 1 subroutine 'cu_ntiedkte_run' + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & + & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx,errmsg,errflg) +!================================================================================================================= +! this is the interface between the model and the mass flux convection module +! m.tiedtke e.c.m.w.f. 1989 +! j.morcrette 1992 +!-------------------------------------------- +! modifications +! C. zhang & Yuqing Wang 2011-2017 +! +! modified from IPRC IRAM - yuqing wang, university of hawaii (ICTP REGCM4.4). +! +! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) +! update notes: +! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. +! the major differences to the old Tiedtke (cu_physics=6) scheme are, +! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; +! Bechtold et al. 2004, 2008, 2014). +! (b) Non-equilibrium situations are considered in the closure for deep convection +! (Bechtold et al. 2014). +! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). +! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). +! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). +! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; +! Wu and Yanai 1994) +! +! other reference: tiedtke (1989, mwr, 117, 1779-1800) +! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 +! +! Note for climate simulation of Tropical Cyclones +! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation +! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km +! Set: momtrans = 2. +! pgcoef = 0.7 to 1.0 is good depends on the basin +! nonequil = .false. + +! Note for the diurnal simulation of precipitaton +! When nonequil = .true., the CAPE is relaxed toward to a value from PBL +! It can improve the diurnal precipitation over land. + +!--- input arguments: + integer,intent(in):: lq,km,km1 + integer,intent(in),dimension(:):: lndj + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(:):: dx + real(kind=kind_phys),intent(in),dimension(:):: evap,hfx + real(kind=kind_phys),intent(in),dimension(:,:):: pqvf,ptf + real(kind=kind_phys),intent(in),dimension(:,:):: poz,pomg,pap + real(kind=kind_phys),intent(in),dimension(:,:):: pzz,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(:):: zprecc + real(kind=kind_phys),intent(inout),dimension(:,:):: pu,pv,pt,pqv,pqc,pqi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + logical,dimension(lq):: locum + integer:: i,j,k + integer,dimension(lq):: icbot,ictop,ktype + + real(kind=kind_phys):: ztmst,fliq,fice,ztc,zalf,tt + real(kind=kind_phys):: ztpp1,zew,zqs,zcor + real(kind=kind_phys):: dxref + + real(kind=kind_phys),dimension(lq):: pqhfl,prsfc,pssfc,phhfl,zrain + real(kind=kind_phys),dimension(lq):: scale_fac,scale_fac2 + + real(kind=kind_phys),dimension(lq,km):: pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo + real(kind=kind_phys),dimension(lq,km):: zqq,pcte + real(kind=kind_phys),dimension(lq,km):: ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat + real(kind=kind_phys),dimension(lq,km1):: pgeoh + +!----------------------------------------------------------------------------------------------------------------- +! + ztmst=dt +! +! set scale-dependency factor when dx is < 15 km +! + dxref = 15000. + do j=1,lq + if (dx(j).lt.dxref) then + scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 + scale_fac2(j) = scale_fac(j)**0.5 + else + scale_fac(j) = 1.+1.33e-5*dx(j) + scale_fac2(j) = 1. + end if + end do +! +! masv flux diagnostics. +! + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + pqhfl(j)=evap(j) + phhfl(j)=hfx(j) + pgeoh(j,km1)=g*pzz(j,km1) + end do +! +! convert model variables for mflux scheme +! + do k=1,km + do j=1,lq + pcte(j,k)=0.0 + pvom(j,k)=0.0 + pvol(j,k)=0.0 + ztp1(j,k)=pt(j,k) + zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) + pum1(j,k)=pu(j,k) + pvm1(j,k)=pv(j,k) + pverv(j,k)=pomg(j,k) + pgeo(j,k)=g*poz(j,k) + pgeoh(j,k)=g*pzz(j,k) + tt=ztp1(j,k) + zew = foeewm(tt) + zqs = zew/pap(j,k) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k)=zqs*zcor + pqte(j,k)=pqvf(j,k) + zqq(j,k) =pqte(j,k) + ptte(j,k)=ptf(j,k) + ztt(j,k) =ptte(j,k) + end do + end do +! +!----------------------------------------------------------------------- +!* 2. call 'cumastrn'(master-routine for cumulus parameterization) +! + call cumastrn & + & (lq, km, km1, km-1, ztp1, & + & zqp1, pum1, pvm1, pverv, zqsat, & + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc, & + & pssfc, locum, & + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain, & + & pcte, phhfl, lndj, pgeoh, dx, & + & scale_fac, scale_fac2) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + do j=1,lq + if(pcte(j,k).gt.0.) then + fliq=foealfa(ztp1(j,k)) + fice=1.0-fliq + pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst + pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst + endif + end do + end do +! + do k=1,km + do j=1,lq + pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(j,k))*ztmst + zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst + pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) + end do + + if (lmfdudv) then + do k=1,km + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k)*ztmst + end do + end do + endif +! + errmsg = 'cu_ntiedtke_run OK' + errflg = 0 +! + return + end subroutine cu_ntiedtke_run + +!############################################################# +! +! level 2 subroutines +! +!############################################################# +!*********************************************************** +! subroutine cumastrn +!*********************************************************** + subroutine cumastrn & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, puen, pven, pverv, pqsen, & + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc, & + & pssfc, ldcum, & + & ktype, kcbot, kctop, ptu, pqu, & + & plu, plude, pmfu, pmfd, prain, & + & pcte, phhfl, lndj, zgeoh, dx, & + & scale_fac, scale_fac2) + implicit none +! +!***cumastrn* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +! modifications +! y.wang i.p.r.c 2001 +! c.zhang 2012 +!***purpose +! ------- +! this routine computes the physical tendencies of the +! prognostic variables t,q,u and v due to convective processes. +! processes considered are: convective fluxes, formation of +! precipitation, evaporation of falling rain below cloud base, +! saturated cumulus downdrafts. +!***method +! ------ +! parameterization is done using a massflux-scheme. +! (1) define constants and parameters +! (2) specify values (t,q,qs...) at half levels and +! initialize updraft- and downdraft-values in 'cuinin' +! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, +! and specify cloud base massflux +! (4) do cloud ascent in 'cuascn' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfsn' +! (b) determine moist descent in 'cuddrafn' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final adjusments to convective fluxes in 'cuflxn', +! do evaporation in subcloud layer +! (7) calculate increments of t and q in 'cudtdqn' +! (8) calculate increments of u and v in 'cududvn' +!***externals. +! ---------- +! cuinin: initializes values at vertical grid used in cu-parametr. +! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus +! cuascn: cloud ascent for entraining plume +! cudlfsn: determines values at lfs for downdrafts +! cuddrafn:does moist descent for cumulus downdrafts +! cuflxn: final adjustments to convective fluxes (also in pbl) +! cudqdtn: updates tendencies for t and q +! cududvn: updates tendencies for u and v +!***switches. +! -------- +! lmfmid=.t. midlevel convection is switched on +! lmfdd=.t. cumulus downdrafts switched on +! lmfdudv=.t. cumulus friction switched on +!*** +! model parameters (defined in subroutine cuparam) +! ------------------------------------------------ +! entrdd entrainment rate for cumulus downdrafts +! cmfcmax maximum massflux value allowed for +! cmfcmin minimum massflux value (for safety) +! cmfdeps fractional massflux for downdrafts at lfs +! cprcon coefficient for conversion from cloud water to rain +!***reference. +! ---------- +! paper on massflux scheme (tiedtke,1989) +!----------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: dx + real(kind=kind_phys),intent(in),dimension(klon):: pqhfl,phhfl + real(kind=kind_phys),intent(in),dimension(klon):: scale_fac,scale_fac2 + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,puen,pven,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,zgeoh + +!--- inout arguments: + integer,intent(inout),dimension(klon):: ktype,kcbot,kctop + logical,intent(inout),dimension(klon):: ldcum + + real(kind=kind_phys),intent(inout),dimension(klon):: pqsen + real(kind=kind_phys),intent(inout),dimension(klon):: prsfc,pssfc,prain + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pcte,ptte,pqte,pvom,pvol + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,plude,pmfu,pmfd + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: loddraf,llo2 + + integer:: jl,jk,ik + integer:: ikb,ikt,icum,itopm2 + integer,dimension(klon):: kdpl,idtop,ictop0,ilwmin + integer,dimension(klon,klev):: ilab + + real(kind=kind_phys):: zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real(kind=kind_phys):: zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real(kind=kind_phys):: zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + real(kind=kind_phys):: zduten,zdvten,ztdis,pgf_u,pgf_v + real(kind=kind_phys):: zlon + real(kind=kind_phys):: ztau,zerate,zderate,zmfa + real(kind=kind_phys),dimension(klon):: zmfs + real(kind=kind_phys),dimension(klon):: zsfl,zcape,zcape1,zcape2,ztauc,ztaubl,zheat + real(kind=kind_phys),dimension(klon):: wup,zdqcv + real(kind=kind_phys),dimension(klon):: wbase,zmfuub + real(kind=kind_phys),dimension(klon):: upbl + real(kind=kind_phys),dimension(klon):: zhcbase,zmfub,zmfub1,zdhpbl + real(kind=kind_phys),dimension(klon):: zmfuvb,zsum12,zsum22 + real(kind=kind_phys),dimension(klon):: zrfl + real(kind=kind_phys),dimension(klev):: pmean + real(kind=kind_phys),dimension(klon,klev):: pmfude_rate,pmfdde_rate + real(kind=kind_phys),dimension(klon,klev):: zdpmel + real(kind=kind_phys),dimension(klon,klev):: zmfuus,zmfdus,zuv2,ztenu,ztenv + real(kind=kind_phys),dimension(klon,klev):: ztenh,zqenh,zqsenh,ztd,zqd + real(kind=kind_phys),dimension(klon,klev):: zmfus,zmfds,zmfuq,zmfdq,zdmfup,zdmfdp,zmful + real(kind=kind_phys),dimension(klon,klev):: zuu,zvu,zud,zvd,zlglac + real(kind=kind_phys),dimension(klon,klevp1):: pmflxr,pmflxs + +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + +!-------------------------------------------------------------- +!* 2. initialize values at vertical grid points in 'cuini' +!-------------------------------------------------------------- + call cuinin & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, paph, zgeoh, ztenh, zqenh, & + & zqsenh, ilwmin, ptu, pqu, ztd, & + & zqd, zuu, zvu, zud, zvd, & + & pmfu, pmfd, zmfus, zmfds, zmfuq, & + & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & + & plude, ilab) + +!---------------------------------- +!* 3.0 cloud base calculations +!---------------------------------- +!* (a) determine cloud base values in 'cutypen', +! and the cumulus type 1 or 2 +! ------------------------------------------- + call cutypen & + & ( klon, klev, klevp1, klevm1, pqen, & + & ztenh, zqenh, zqsenh, zgeoh, paph, & + & phhfl, pqhfl, pgeo, pqsen, pap, & + & pten, lndj, ptu, pqu, ilab, & + & ldcum, kcbot, ictop0, ktype, wbase, & + & plu, kdpl) + +!* (b) assign the first guess mass flux at cloud base +! ------------------------------------------ + do jl=1,klon + zdhpbl(jl)=0.0 + upbl(jl) = 0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + if(jk.ge.kcbot(jl) .and. ldcum(jl)) then + zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& + & *(paph(jl,jk+1)-paph(jl,jk)) + if(lndj(jl) .eq. 0) then + wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) + upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(ktype(jl) == 1) then + zmfub(jl)= 0.1*zmfmax + else if ( ktype(jl) == 2 ) then + zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) + zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) + zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe + zdh = g*max(zdh,1.e5*zdqmin) + if ( zdhpbl(jl) > 0. ) then + zmfub(jl) = zdhpbl(jl)/zdh + zmfub(jl) = min(zmfub(jl),zmfmax) + else + zmfub(jl) = 0.1*zmfmax + ldcum(jl) = .false. + end if + end if + else + zmfub(jl) = 0. + end if + end do +!------------------------------------------------------ +!* 4.0 determine cloud ascent for entraining plume +!------------------------------------------------------ +!* (a) do ascent in 'cuasc'in absence of downdrafts +!---------------------------------------------------------- + call cuascn & + & (klon, klev, klevp1, klevm1, ztenh, & + & zqenh, puen, pven, pten, pqen, & + & pqsen, pgeo, zgeoh, pap, paph, & + & pqte, pverv, ilwmin, ldcum, zhcbase, & + & ktype, ilab, ptu, pqu, plu, & + & zuu, zvu, pmfu, zmfub, & + & zmfus, zmfuq, zmful, plude, zdmfup, & + & kcbot, kctop, ictop0, icum, ztmst, & + & zqsenh, zlglac, lndj, wup, wbase, & + & kdpl, pmfude_rate) + +!* (b) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) +!------------------------------------------------------------------ + do jl=1,klon + if ( ldcum(jl) ) then + ikb = kcbot(jl) + itopm2 = kctop(jl) + zpbmpt = paph(jl,ikb) - paph(jl,itopm2) + if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 + if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 + ictop0(jl) = kctop(jl) + end if + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do + + do jk = 1,klev + do jl = 1,klon + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + zdpmel(jl,jk) = 0. + end do + end do + +!----------------------------------------- +!* 6.0 cumulus downdraft calculations +!----------------------------------------- + if(lmfdd) then +!* (a) determine lfs in 'cudlfsn' +!-------------------------------------- + call cudlfsn & + & (klon, klev,& + & kcbot, kctop, lndj, ldcum, & + & ztenh, zqenh, puen, pven, & + & pten, pqsen, pgeo, & + & zgeoh, paph, ptu, pqu, plu, & + & zuu, zvu, zmfub, zrfl, & + & ztd, zqd, zud, zvd, & + & pmfd, zmfds, zmfdq, zdmfdp, & + & idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddrafn' +!------------------------------------------------------------ + call cuddrafn & + & (klon, klev, loddraf, & + & ztenh, zqenh, puen, pven, & + & pgeo, zgeoh, paph, zrfl, & + & ztd, zqd, zud, zvd, pmfu, & + & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate) +!----------------------------------------------------------- + end if +! +!----------------------------------------------------------------------- +!* 6.0 closure and clean work +! ------ +!-- 6.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) +! + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 1) then + ikb = kcbot(jl) + ikt = kctop(jl) + zheat(jl)=0.0 + zcape(jl)=0.0 + zcape1(jl)=0.0 + zcape2(jl)=0.0 + zmfub1(jl)=zmfub(jl) + + ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & + ((2.+ min(15.0,wup(jl)))*g) + if(lndj(jl) .eq. 0) then + upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) + ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) + ztaubl(jl) = min(300., ztaubl(jl)) + else + ztaubl(jl) = ztauc(jl) + end if + end if + end do +! + do jk = 1 , klev + do jl = 1 , klon + llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 + if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then + ikb = kcbot(jl) + zdz = pgeo(jl,jk-1)-pgeo(jl,jk) + zdp = pap(jl,jk)-pap(jl,jk-1) + zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & + ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & + (g*(pmfu(jl,jk)+pmfd(jl,jk))) + zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & + vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp + end if + + if ( llo1 .and. jk >= kcbot(jl) ) then + if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then + zdp = paph(jl,jk+1)-paph(jl,jk) + zcape2(jl) = zcape2(jl) + ztaubl(jl)* & + ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ikb = kcbot(jl) + ikt = kctop(jl) + ztauc(jl) = max(ztmst,ztauc(jl)) + ztauc(jl) = max(360.,ztauc(jl)) + ztauc(jl) = min(10800.,ztauc(jl)) + ztau = ztauc(jl) * scale_fac(jl) + if(nonequil) then + zcape2(jl)= max(0.,zcape2(jl)) + zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) + else + zcape(jl) = max(0.,min(zcape1(jl),5000.)) + end if + zheat(jl) = max(1.e-4,zheat(jl)) + zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) + zmfub1(jl) = max(zmfub1(jl),0.001) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do +! +!* 6.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moist static energy budget (ktype=2) +!-------------------------------------------------------- + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 2) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then + zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) + else + zeps=0. + endif + zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & + & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 +! using moist static engergy closure instead of moisture closure + zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & + & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe + zdh=g*max(zdh,1.e5*zdqmin) + if(zdhpbl(jl).gt.0.)then + zmfub1(jl)=zdhpbl(jl)/zdh + else + zmfub1(jl) = zmfub(jl) + end if + zmfub1(jl) = zmfub1(jl)/scale_fac2(jl) + zmfub1(jl) = min(zmfub1(jl),zmfmax) + end if + +!* 6.3 mid-level convection - nothing special +!--------------------------------------------------------- + if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then + zmfub1(jl) = zmfub(jl) + end if + + end do + +!* 6.4 scaling the downdraft mass flux +!--------------------------------------------------------- + do jk=1,klev + do jl=1,klon + if( ldcum(jl) ) then + zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) + pmfd(jl,jk)=pmfd(jl,jk)*zfac + zmfds(jl,jk)=zmfds(jl,jk)*zfac + zmfdq(jl,jk)=zmfdq(jl,jk)*zfac + zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac + end if + end do + end do + +!* 6.5 scaling the updraft mass flux +! -------------------------------------------------------- + do jl = 1,klon + if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + ikb = kcbot(jl) + if ( jk>ikb ) then + zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + pmfu(jl,jk) = pmfu(jl,ikb)*zdz + end if + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then + pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) + zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) + zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) + zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) + plude(jl,jk) = plude(jl,jk)*zmfs(jl) + pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + end if + end do + end do + +!* 6.6 if ktype = 2, kcbot=kctop is not allowed +! --------------------------------------------------- + do jl = 1,klon + if ( ktype(jl) == 2 .and. & + kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then + ldcum(jl) = .false. + ktype(jl) = 0 + end if + end do + + if ( .not. lmfscv .or. .not. lmfpen ) then + do jl = 1,klon + llo2(jl) = .false. + if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & + (.not. lmfpen .and. ktype(jl) == 1) ) then + llo2(jl) = .true. + ldcum(jl) = .false. + end if + end do + end if + +!* 6.7 set downdraft mass fluxes to zero above cloud top +!---------------------------------------------------- + do jl = 1,klon + if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then + idtop(jl) = kctop(jl) + 1 + end if + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) ) then + if ( jk < idtop(jl) ) then + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + else if ( jk == idtop(jl) ) then + pmfdde_rate(jl,jk) = 0. + end if + end if + end do + end do +!---------------------------------------------------------- +!* 7.0 determine final convective fluxes in 'cuflx' +!---------------------------------------------------------- + call cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ztenh, zqenh & + & , paph, pap, zgeoh, lndj, ldcum & + & , kcbot, kctop, idtop, itopm2 & + & , ktype, loddraf & + & , pmfu, pmfd, zmfus, zmfds & + & , zmfuq, zmfdq, zmful, plude & + & , zdmfup, zdmfdp, zdpmel, zlglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! some adjustments needed + do jl=1,klon + zmfs(jl) = 1. + zmfuub(jl)=0. + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zmfmax = pmfu(jl,jk)*0.98 + if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then + zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) + end if + end if + end do + end do + + do jk = 2 , klev + do jl = 1 , klon + if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then + pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) + zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) + pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) + zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) + end if + end do + end do + + do jk = 2 , klev - 1 + do jl = 1, klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) + if ( zerate < 0. ) then + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate + end if + end if + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) + if ( zerate < 0. ) then + pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate + end if + zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & + pmflxr(jl,jk) - pmflxs(jl,jk) + zdmfdp(jl,jk) = 0. + end if + end do + end do + +! avoid negative humidities at ddraught top + do jl = 1,klon + if ( loddraf(jl) ) then + jk = idtop(jl) + ik = min(jk+1,klev) + if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then + zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) + end if + end if + end do + +! avoid negative humidities near cloud top because gradient of precip flux +! and detrainment / liquid water flux are too large + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then + zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) + zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & + zmfuq(jl,jk) - zmfdq(jl,jk) + & + zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) + zmfa = (zmfa-plude(jl,jk))*zdz + if ( pqen(jl,jk)+zmfa < 0. ) then + plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz + end if + if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. + end if + if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. + if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. + end do + end do + + do jl=1,klon + prsfc(jl) = pmflxr(jl,klev+1) + pssfc(jl) = pmflxs(jl,klev+1) + end do + +!---------------------------------------------------------------- +!* 8.0 update tendencies for t and q in subroutine cudtdq +!---------------------------------------------------------------- + call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & + ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & + zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & + zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) +!---------------------------------------------------------------- +!* 9.0 update tendencies for u and u in subroutine cududv +!---------------------------------------------------------------- + if(lmfdudv) then + do jk = klev-1 , 2 , -1 + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then + ikb = kdpl(jl) + zuu(jl,jk) = puen(jl,ikb-1) + zvu(jl,jk) = pven(jl,ikb-1) + else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then + zuu(jl,jk) = puen(jl,jk-1) + zvu(jl,jk) = pven(jl,jk-1) + end if + if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then + if(momtrans .eq. 1)then + zfac = 0. + if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. + if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. + zerate = pmfu(jl,jk) - pmfu(jl,ik) + & + (1.+zfac)*pmfude_rate(jl,jk) + zderate = (1.+zfac)*pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa + else + pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) + zderate = pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa + end if + end if + end if + end do + end do + + if(lmfdd) then + do jk = 3 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == idtop(jl) ) then + zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) + zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) + else if ( jk > idtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & + zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa + zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & + zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa + end if + end if + end do + end do + end if +! -------------------------------------------------- +! rescale massfluxes for stability in Momentum +!------------------------------------------------------------------------ + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons + if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + zmfuus(jl,jk) = pmfu(jl,jk) + zmfdus(jl,jk) = pmfd(jl,jk) + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + end if + end do + end do +!* 9.1 update u and v in subroutine cududvn +!------------------------------------------------------------------- + do jk = 1 , klev + do jl = 1, klon + ztenu(jl,jk) = pvom(jl,jk) + ztenv(jl,jk) = pvol(jl,jk) + end do + end do + + call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & + ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & + zud,zvu,zvd,pvom,pvol) + +! calculate KE dissipation + do jl = 1, klon + zsum12(jl) = 0. + zsum22(jl) = 0. + end do + do jk = 1 , klev + do jl = 1, klon + zuv2(jl,jk) = 0. + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zdz = (paph(jl,jk+1)-paph(jl,jk)) + zduten = pvom(jl,jk) - ztenu(jl,jk) + zdvten = pvol(jl,jk) - ztenv(jl,jk) + zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) + zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz + zsum12(jl) = zsum12(jl) - & + (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then + ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) + ptte(jl,jk) = ptte(jl,jk) + ztdis + end if + end do + end do + + end if + +!---------------------------------------------------------------------- +!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF +! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO +! --------------------------------------------------- + if ( .not. lmfscv .or. .not. lmfpen ) then + do jk = 2 , klev + do jl = 1, klon + if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then + ptu(jl,jk) = pten(jl,jk) + pqu(jl,jk) = pqen(jl,jk) + plu(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + end if + end do + end do + do jl = 1, klon + if ( llo2(jl) ) then + kctop(jl) = klev - 1 + kcbot(jl) = klev - 1 + end if + end do + end if + + return + end subroutine cumastrn + +!********************************************** +! level 3 subroutine cuinin +!********************************************** +! + subroutine cuinin & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, paph, pgeoh, ptenh, pqenh, & + & pqsenh, klwmin, ptu, pqu, ptd, & + & pqd, puu, pvu, pud, pvd, & + & pmfu, pmfd, pmfus, pmfds, pmfuq, & + & pmfdq, pdmfup, pdmfdp, pdpmel, plu, & + & plude, klab) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose +! ------- +! this routine interpolates large-scale fields of t,q etc. +! to half levels (i.e. grid for massflux scheme), +! and initializes values for updrafts and downdrafts +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! for extrapolation to half levels see tiedtke(1989) +!***externals +! --------- +! *cuadjtq* to specify qs at half levels +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: klwmin + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,ptd,pqu,pqd,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: puu,pud,pvu,pvd + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfd,pmfus,pmfds,pmfuq,pmfdq + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pdmfup,pdmfdp,plude,pdpmel + +!--- local variables and arrays: + logical,dimension(klon):: loflag + integer:: jl,jk + integer:: icall,ik + real(kind=kind_phys):: zzs + real(kind=kind_phys),dimension(klon):: zph,zwmax + +!------------------------------------------------------------ +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity +! ----------------------------------------------------------- + do jk=2,klev + do jl=1,klon + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqenh(jl,jk) = pqen(jl,jk-1) + pqsenh(jl,jk)= pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. + end do + + if ( jk >= klev-1 .or. jk < 2 ) cycle + ik=jk + icall=0 + call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) + do jl=1,klon + pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & + & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) + pqenh(jl,jk)=max(pqenh(jl,jk),0.) + end do + end do + + do jl=1,klon + ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & + & pgeoh(jl,klev))*rcpd + pqenh(jl,klev)=pqen(jl,klev) + ptenh(jl,1)=pten(jl,1) + pqenh(jl,1)=pqen(jl,1) + klwmin(jl)=klev + zwmax(jl)=0. + end do + + do jk=klevm1,2,-1 + do jl=1,klon + zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & + & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) + ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd + end do + end do + + do jk=klev,3,-1 + do jl=1,klon + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do + end do +!----------------------------------------------------------- +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 + do jl=1,klon + ptu(jl,jk)=ptenh(jl,jk) + ptd(jl,jk)=ptenh(jl,jk) + pqu(jl,jk)=pqenh(jl,jk) + pqd(jl,jk)=pqenh(jl,jk) + plu(jl,jk)=0. + puu(jl,jk)=puen(jl,ik) + pud(jl,jk)=puen(jl,ik) + pvu(jl,jk)=pven(jl,ik) + pvd(jl,jk)=pven(jl,ik) + klab(jl,jk)=0 + end do + end do + return + end subroutine cuinin + +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cutypen & + & ( klon, klev, klevp1, klevm1, pqen, & + & ptenh, pqenh, pqsenh, pgeoh, paph, & + & hfx, qfx, pgeo, pqsen, pap, & + & pten, lndj, cutu, cuqu, culab, & + & ldcum, cubot, cutop, ktype, wbase, & + & culu, kdpl) +! zhang & wang iprc 2011-2013 +!***purpose. +! -------- +! to produce first guess updraught for cu-parameterizations +! calculates condensation level, and sets updraught base variables and +! first guess cloud type +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud types as follows; +! ktype=1 for deep cumulus +! ktype=2 for shallow cumulus +!***method. +! -------- +! based on a simplified updraught equation +! partial(hup)/partial(z)=eta(h - hup) +! eta is the entrainment rate for test parcel +! h stands for dry static energy or the total water specific humidity +! references: christian jakob, 2003: a new subcloud model for +! mass-flux convection schemes +! influence on triggering, updraft properties, and model +! climate, mon.wea.rev. +! 131, 2765-2778 +! and +! ifs documentation - cy36r1,cy38r1 +!***input variables: +! ptenh [ztenh] - environment temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! paph - pressure of half levels. (mssflx) +! rho - density of the lowest model level +! qfx - net upward moisture flux at the surface (kg/m^2/s) +! hfx - net upward heat flux at the surface (w/m^2) +!***variables output by cutype: +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in),dimension(klon):: qfx,hfx + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- output arguments: + logical,intent(out),dimension(klon):: ldcum + + integer,intent(out),dimension(klon):: ktype + integer,intent(out),dimension(klon):: cubot,cutop,kdpl + integer,intent(out),dimension(klon,klev):: culab + + real(kind=kind_phys),intent(out),dimension(klon):: wbase + real(kind=kind_phys),intent(out),dimension(klon,klev):: cutu,cuqu,culu + +!--- local variables and arrays: + logical:: needreset + logical,dimension(klon):: lldcum + logical,dimension(klon):: loflag,deepflag,resetflag + + integer:: jl,jk,ik,icall,levels + integer:: nk,is,ikb,ikt + integer,dimension(klon):: kctop,kcbot + integer,dimension(klon):: zcbase,itoppacel + integer,dimension(klon,klev):: klab + + real(kind=kind_phys):: rho,part1,part2,root,conw,deltt,deltq + real(kind=kind_phys):: zz,zdken,zdq + real(kind=kind_phys):: fscale,crirh1,pp + real(kind=kind_phys):: atop1,atop2,abot + real(kind=kind_phys):: tmix,zmix,qmix,pmix + real(kind=kind_phys):: zlglac,dp + real(kind=kind_phys):: zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys):: zpdifftop, zpdiffbot + + real(kind=kind_phys),dimension(klon):: eta,dz,coef,zqold,zph + real(kind=kind_phys),dimension(klon,klev):: dh,dhen,kup,vptu,vten + real(kind=kind_phys),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),dimension(klon,klev):: zbuo,abuoy,plude + +!-------------------------------------------------------------- + do jl=1,klon + kcbot(jl)=klev + kctop(jl)=klev + kdpl(jl) =klev + ktype(jl)=0 + wbase(jl)=0. + ldcum(jl)=.false. + end do + +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is klev +! define deltat and deltaq +!----------------------------------------------------------- + do jk=1,klev + do jl=1,klon + plu(jl,jk)=culu(jl,jk) ! parcel liquid water + ptu(jl,jk)=cutu(jl,jk) ! parcel temperature + pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity + klab(jl,jk)=culab(jl,jk) + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + vten(jl,jk)=0.0 ! environment virtual temperature + zbuo(jl,jk)=0.0 ! parcel buoyancy + abuoy(jl,jk)=0.0 + end do + end do + + do jl=1,klon + zqold(jl) = 0. + lldcum(jl) = .false. + loflag(jl) = .true. + end do + +! check the levels from lowest level to second top level + do jk=klevm1,2,-1 + +! define the variables at the first level + if(jk .eq. klevm1) then + do jl=1,klon + rho=pap(jl,klev)/ & + & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) + part1 = 1.5*0.4*pgeo(jl,klev)/ & + & (rho*pten(jl,klev)) + part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) + root = 0.001-part1*part2 + if(part2 .lt. 0.) then + conw = 1.2*(root)**t13 + deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) + deltq = max(1.5*qfx(jl)/(rho*conw),0.) + kup(jl,klev) = 0.5*(conw**2) + pqu(jl,klev)= pqenh(jl,klev) + deltq + dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd + dh(jl,klev) = dhen(jl,klev) + deltt*cpd + ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd + vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) + vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) + zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) + klab(jl,klev) = 1 + else + loflag(jl) = .false. + end if + end do + end if + + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then + eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = min(plu(jl,jk),5.e-3) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot + +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 2 + ldcum(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = klev + else + cutop(jl) = -1 + cubot(jl) = -1 + kdpl(jl) = klev - 1 + ldcum(jl) = .false. + wbase(jl) = 0. + end if + end do + + do jk=klev,1,-1 + do jl=1,klon + ikt = kctop(jl) + if(jk .ge. ikt)then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + end if + end do + end do + +!----------------------------------------------------------- +! next, let's check the deep convection +! the first level is klevm1-1 +! define deltat and deltaq +!---------------------------------------------------------- +! we check the parcel starting level by level +! assume the mix-layer is 60hPa + deltt = 0.2 + deltq = 1.0e-4 + do jl=1,klon + deepflag(jl) = .false. + end do + + do jk=klev,1,-1 + do jl=1,klon + if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk + end do + end do + + do levels=klevm1-1,klev/2+1,-1 ! loop starts + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0.0 ! parcel liquid water + ptu(jl,jk)=0.0 ! parcel temperature + pqu(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading + vten(jl,jk)=0.0 ! environment virtual temperature + abuoy(jl,jk)=0.0 + zbuo(jl,jk)=0.0 + klab(jl,jk)=0 + end do + end do + + do jl=1,klon + kcbot(jl) = levels + kctop(jl) = levels + zqold(jl) = 0. + lldcum(jl) = .false. + resetflag(jl)= .false. + loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) + end do + +! start the inner loop to search the deep convection points + do jk=levels,2,-1 + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! define the variables at the departure level + if(jk .eq. levels) then + do jl=1,klon + if(loflag(jl)) then + if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then + tmix=0. + qmix=0. + zmix=0. + pmix=0. + do nk=jk+2,jk,-1 + if(pmix < 50.e2) then + dp = paph(jl,nk) - paph(jl,nk-1) + tmix=tmix+dp*ptenh(jl,nk) + qmix=qmix+dp*pqenh(jl,nk) + zmix=zmix+dp*pgeoh(jl,nk) + pmix=pmix+dp + end if + end do + tmix=tmix/pmix + qmix=qmix/pmix + zmix=zmix/pmix + else + tmix=ptenh(jl,jk+1) + qmix=pqenh(jl,jk+1) + zmix=pgeoh(jl,jk+1) + end if + + pqu(jl,jk+1) = qmix + deltq + dhen(jl,jk+1)= zmix + tmix*cpd + dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd + ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd + kup(jl,jk+1) = 0.5 + klab(jl,jk+1)= 1 + vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) + vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) + zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) + end if + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then +! define the fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) + eta(jl) = 1.75e-3*fscale + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = 0.5*plu(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + needreset = .false. + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 1 + ldcum(jl) = .true. + deepflag(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = levels+1 + needreset = .true. + resetflag(jl)= .true. + end if + end do + + if(needreset) then + do jk=klev,1,-1 + do jl=1,klon + if(resetflag(jl)) then + ikt = kctop(jl) + ikb = kdpl(jl) + if(jk .le. ikb .and. jk .ge. ikt )then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + else + culab(jl,jk) = 1 + cutu(jl,jk) = ptenh(jl,jk) + cuqu(jl,jk) = pqenh(jl,jk) + culu(jl,jk) = 0. + end if + if ( jk .lt. ikt ) culab(jl,jk) = 0 + end if + end do + end do + end if + + end do ! end all cycles + + return + end subroutine cutypen + +!----------------------------------------------------------------- +! level 3 subroutines 'cuascn' +!----------------------------------------------------------------- + subroutine cuascn & + & (klon, klev, klevp1, klevm1, ptenh, & + & pqenh, puen, pven, pten, pqen, & + & pqsen, pgeo, pgeoh, pap, paph, & + & pqte, pverv, klwmin, ldcum, phcbase, & + & ktype, klab, ptu, pqu, plu, & + & puu, pvu, pmfu, pmfub, & + & pmfus, pmfuq, pmful, plude, pdmfup, & + & kcbot, kctop, kctop0, kcum, ztmst, & + & pqsenh, plglac, lndj, wup, wbase, & + & kdpl, pmfude_rate) + + implicit none +! this routine does the calculations for cloud ascents +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +! y.wang iprc 11/01 modif. +! c.zhang iprc 05/12 modif. +!***purpose. +! -------- +! to produce cloud ascents for cu-parametrization +! (vertical profiles of t,q,l,u and v and corresponding +! fluxes as well as precipitation rates) +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! lift surface air dry-adiabatically to cloud base +! and then calculate moist ascent for +! entraining/detraining plume. +! entrainment and detrainment rates differ for +! shallow and deep cumulus convection. +! in case there is no penetrative or shallow convection +! check for possibility of mid level convection +! (cloud base values calculated in *cubasmc*) +!***externals +! --------- +! *cuadjtqn* adjust t and q due to condensation in ascent +! *cuentrn* calculate entrainment/detrainment rates +! *cubasmcn* calculate cloud base values for midlevel convection +!***reference +! --------- +! (tiedtke,1989) +!***input variables: +! ptenh [ztenh] - environ temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! puen - environment wind u-component. (mssflx) +! pven - environment wind v-component. (mssflx) +! pten - environment temperature. (mssflx) +! pqen - environment specific humidity. (mssflx) +! pqsen - environment saturation specific humidity. (mssflx) +! pgeo - geopotential. (mssflx) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! pap - pressure in pa. (mssflx) +! paph - pressure of half levels. (mssflx) +! pqte - moisture convergence (delta q/delta t). (mssflx) +! pverv - large scale vertical velocity (omega). (mssflx) +! klwmin [ilwmin] - level of minimum omega. (cuini) +! klab [ilab] - level label - 1: sub-cloud layer. +! 2: condensation level (cloud base) +! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) +!***variables modified by cuasc: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! puu [zuu] - cloud momentum u-component. +! pvu [zvu] - cloud momentum v-component. +! pmfu - updraft mass flux. +! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) +! pmfuq [zmfuq] - updraft flux of specific humidity. +! pmful [zmful] - updraft flux of cloud liquid water. +! plude - liquid water returned to environment by detrainment. +! pdmfup [zmfup] - +! kcbot - cloud base level. (cubase) +! kctop - cloud top level +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - flag to control the call + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: klwmin + integer,intent(in),dimension(klon):: kdpl + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: wbase + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven,pqte,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- inout arguments: + logical,intent(inout),dimension(klon):: ldcum + + integer,intent(inout):: kcum + integer,intent(inout),dimension(klon):: kcbot,kctop,kctop0 + integer,intent(inout),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(inout),dimension(klon):: phcbase + real(kind=kind_phys),intent(inout),dimension(klon):: pmfub + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,puu,pvu + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful,plude,pdmfup + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype + + real(kind=kind_phys),intent(out),dimension(klon):: wup + real(kind=kind_phys),intent(out),dimension(klon,klev):: plglac,pmfude_rate + +!--- local variables and arrays: + logical:: llo2,llo3 + logical,dimension(klon):: loflag,llo1 + + integer:: jl,jk + integer::ikb,icum,itopm2,ik,icall,is,jlm,jll + integer,dimension(klon):: jlx + + real(kind=kind_phys):: zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real(kind=kind_phys):: zmftest,zmfmax,zqeen,zseen,zscde,zqude + real(kind=kind_phys):: zmfusk,zmfuqk,zmfulk + real(kind=kind_phys):: zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real(kind=kind_phys):: zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real(kind=kind_phys):: zrnew,zz,zdmfeu,zdmfdu,dp + real(kind=kind_phys):: zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real(kind=kind_phys):: atop1,atop2,abot + + real(kind=kind_phys),dimension(klon):: eta,dz,zoentr,zdpmean + real(kind=kind_phys),dimension(klon):: zph,zdmfen,zdmfde,zmfuu,zmfuv,zpbase,zqold,zluold,zprecip + real(kind=kind_phys),dimension(klon,klev):: zlrain,zbuo,kup,zodetr,pdmfen + +!-------------------------------- +!* 1. specify parameters +!-------------------------------- + zcons2=3./(g*ztmst) + zfacbuo = 0.5/(1.+0.5) + zprcdgw = cprcon*zrg + z_cldmax = 5.e-3 + z_cwifrac = 0.5 + z_cprc2 = 0.5 + z_cwdrag = (3.0/8.0)*0.506/0.2 +!--------------------------------- +! 2. set default values +!--------------------------------- + llo3 = .false. + do jl=1,klon + zluold(jl)=0. + wup(jl)=0. + zdpmean(jl)=0. + zoentr(jl)=0. + if(.not.ldcum(jl)) then + ktype(jl)=0 + kcbot(jl) = -1 + pmfub(jl) = 0. + pqu(jl,klev) = 0. + end if + end do + + ! initialize variout quantities + do jk=1,klev + do jl=1,klon + if(jk.ne.kcbot(jl)) plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk)=0. + zlrain(jl,jk)=0. + zbuo(jl,jk)=0. + kup(jl,jk)=0. + pdmfen(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 + if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk + end do + end do + + do jl = 1,klon + if ( ktype(jl) == 3 ) ldcum(jl) = .false. + end do +!------------------------------------------------ +! 3.0 initialize values at cloud base level +!------------------------------------------------ + do jl=1,klon + kctop(jl)=kcbot(jl) + if(ldcum(jl)) then + ikb = kcbot(jl) + kup(jl,ikb) = 0.5*wbase(jl)**2 + pmfu(jl,ikb) = pmfub(jl) + pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) + pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) + pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) + end if + end do +! +!----------------------------------------------------------------- +! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) +! by doing first dry-adiabatic ascent and then +! by adjusting t,q and l accordingly in *cuadjtqn*, +! then check for buoyancy and set flags accordingly +!----------------------------------------------------------------- +! + do jk=klevm1,3,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection +! --------------------------------------------------------------------- + ik=jk + call cubasmcn& + & (klon, klev, klevm1, ik, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, pgeoh, ldcum, ktype, klab, zlrain, & + & pmfu, pmfub, kcbot, ptu, & + & pqu, plu, puu, pvu, pmfus, & + & pmfuq, pmful, pdmfup) + is = 0 + jlm = 0 + do jl = 1,klon + loflag(jl) = .false. + zprecip(jl) = 0. + llo1(jl) = .false. + is = is + klab(jl,jk+1) + if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 + if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & + (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then + loflag(jl) = .true. + jlm = jlm + 1 + jlx(jlm) = jl + end if + zph(jl) = paph(jl,jk) + if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfub(jl) > zmfmax ) then + zfac = zmfmax/pmfub(jl) + pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac + pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac + pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac + pmfub(jl) = zmfmax + end if + pmfub(jl)=min(pmfub(jl),zmfmax) + end if + end do + + if(is.gt.0) llo3 = .true. +! +!* specify entrainment rates in *cuentr* +! ------------------------------------- + ik=jk + call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & + pgeoh,pmfu,zdmfen,zdmfde) +! +! do adiabatic ascent for entraining/detraining plume + if(llo3) then +! ------------------------------------------------------- +! + do jl = 1,klon + zqold(jl) = 0. + end do + do jll = 1 , jlm + jl = jlx(jll) + zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + if ( jk == kcbot(jl) ) then + zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & + 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) + end if + if ( jk < kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + zxs = max(pmfu(jl,jk+1)-zmfmax,0.) + wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) + zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) + zdmfen(jl) = zoentr(jl) + if ( ktype(jl) >= 2 ) then + zdmfen(jl) = 2.0*zdmfen(jl) + zdmfde(jl) = zdmfen(jl) + end if + zdmfde(jl) = zdmfde(jl) * & + (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) + zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zchange = max(zmftest-zmfmax,0.) + zxe = max(zchange-zxs,0.) + zdmfen(jl) = zdmfen(jl) - zxe + zchange = zchange - zxe + zdmfde(jl) = zdmfde(jl) + zchange + end if + pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zqeen = pqenh(jl,jk+1)*zdmfen(jl) + zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) + zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) + zqude = pqu(jl,jk+1)*zdmfde(jl) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + zmfusk = pmfus(jl,jk+1) + zseen - zscde + zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude + zmfulk = pmful(jl,jk+1) - plude(jl,jk) + plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) + pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) + ptu(jl,jk) = (zmfusk * & + (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd + ptu(jl,jk) = max(100.,ptu(jl,jk)) + ptu(jl,jk) = min(400.,ptu(jl,jk)) + zqold(jl) = pqu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & + (1./max(cmfcmin,pmfu(jl,jk))) + zluold(jl) = plu(jl,jk) + end do +! reset to environmental values if below departure level + do jl = 1,klon + if ( jk > kdpl(jl) ) then + ptu(jl,jk) = ptenh(jl,jk) + pqu(jl,jk) = pqenh(jl,jk) + plu(jl,jk) = 0. + zluold(jl) = plu(jl,jk) + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* +!------------------------------------------------ + ik=jk + icall=1 +! + if ( jlm > 0 ) then + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + end if +! compute the upfraft speed in cloud layer + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + plglac(jl,jk) = plu(jl,jk) * & + ((1.-foealfa(ptu(jl,jk)))- & + (1.-foealfa(ptu(jl,jk+1)))) + ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + klab(jl,jk) = 2 + plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) + zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & + zlrain(jl,jk+1)) + zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = zbc - zbe +! set flags for the case of midlevel convection + if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then + if ( zbuo(jl,jk) > -0.5 ) then + ldcum(jl) = .true. + kctop(jl) = jk + kup(jl,jk) = 0.5 + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + plude(jl,jk) = 0. + plu(jl,jk) = 0. + end if + end if + if ( klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then + ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) + pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) + zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + end if + zbuoc = (zbuo(jl,jk) / & + (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & + (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 + zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc +! mixing and "pressure" gradient term in upper troposphere + if ( zdmfen(jl) > 0. ) then + zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + else + zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + end if + kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & + (1.+zdken) + if ( zbuo(jl,jk) < 0. ) then + zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) + zkedke = max(0.,min(1.,zkedke)) + zmfun = sqrt(zkedke)*pmfu(jl,jk+1) + zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + end if + if ( zbuo(jl,jk) > -0.2 ) then + ikb = kcbot(jl) + zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & + pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & + zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) + else + zoentr(jl) = 0. + end if +! erase values if below departure level + if ( jk > kdpl(jl) ) then + pmfu(jl,jk) = pmfu(jl,jk+1) + kup(jl,jk) = 0.5 + end if + if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then + kctop(jl) = jk + llo1(jl) = .true. + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + end if +! save detrainment rates for updraught + if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) + end if + else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfude_rate(jl,jk) = zdmfde(jl) + end if + end do + + do jl = 1,klon + if ( llo1(jl) ) then +! conversions only proceeds if plu is greater than a threshold liquid water +! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation +! generation from small water contents. + if ( lndj(jl).eq.1 ) then + zdshrd = 5.e-4 + else + zdshrd = 3.e-4 + end if + ikb=kcbot(jl) + if ( plu(jl,jk) > zdshrd )then + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) + zprcon = zprcdgw/(0.75*zwu) +! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) + zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) + zcbf = 1. + z_cprc2*sqrt(zdt) + zzco = zprcon*zcbf + zlcrit = zdshrd/zcbf + zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) + zc = (plu(jl,jk)-zluold(jl)) + zarg = (plu(jl,jk)/zlcrit)**2 + if ( zarg < 25.0 ) then + zd = zzco*(1.-exp(-zarg))*zdfi + else + zd = zzco*zdfi + end if + zint = exp(-zd) + zlnew = zluold(jl)*zint + zc/zd*(1.-zint) + zlnew = max(0.,min(plu(jl,jk),zlnew)) + zlnew = min(z_cldmax,zlnew) + zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) + pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) + plu(jl,jk) = zlnew + end if + end if + end do + do jl = 1, klon + if ( llo1(jl) ) then + if ( zlrain(jl,jk) > 0. ) then + zvw = 21.18*zlrain(jl,jk)**0.2 + zvi = z_cwifrac*zvw + zalfaw = foealfa(ptu(jl,jk)) + zvv = zalfaw*zvw + (1.-zalfaw)*zvi + zrold = zlrain(jl,jk) - zprecip(jl) + zc = zprecip(jl) + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) + zd = zvv/zwu + zint = exp(-zd) + zrnew = zrold*zint + zc/zd*(1.-zint) + zrnew = max(0.,min(zlrain(jl,jk),zrnew)) + zlrain(jl,jk) = zrnew + end if + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) + pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) + end do + end if + end do +!---------------------------------------------------------------------- +! 5. final calculations +! ------------------ + do jl = 1,klon + if ( kctop(jl) == -1 ) ldcum(jl) = .false. + kcbot(jl) = max(kcbot(jl),kctop(jl)) + if ( ldcum(jl) ) then + wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) + wup(jl) = sqrt(2.*wup(jl)) + end if + end do + + return + end subroutine cuascn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu, & + & puu, pvu, pmfub, prfl, & + & ptd, pqd, pud, pvd, & + & pmfd, pmfds, pmfdq, pdmfdp, & + & kdtop, lddraf) + +! this routine calculates level of free sinking for +! cumulus downdrafts and specifies t,q,u and v values + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce lfs-values for cumulus downdrafts +! for massflux cumulus parameterization + +! interface +! --------- +! this routine is called from *cumastr*. +! input are environmental values of t,q,u,v,p,phi +! and updraft values t,q,u and v and also +! cloud base massflux and cu-precipitation rate. +! it returns t,q,u and v values and massflux at lfs. +! method. + +! check for negative buoyancy of air of equal parts of +! moist environmental air and cloud air. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pten* provisional environment temperature (t+1) k +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *ptu* temperature in updrafts k +! *pqu* spec. humidity in updrafts kg/kg +! *plu* liquid water content in updrafts kg/kg +! *puu* u-velocity in updrafts m/s +! *pvu* v-velocity in updrafts m/s +! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! output parameters (integer): + +! *kdtop* top level of downdrafts + +! output parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! externals +! --------- +! *cuadjtq* for calculating wet bulb t and q at lfs +!---------------------------------------------------------------------- + + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: kcbot,kctop + + real(kind=kind_phys),intent(in),dimension(klon):: pmfub + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqsen,pgeo,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptu,pqu,puu,pvu,plu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pud,pvd + +!--- output arguments: + logical,intent(out),dimension(klon):: lddraf + integer,intent(out),dimension(klon):: kdtop + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptd,pqd,pmfd,pmfds,pmfdq,pdmfdp + +!--- local variables and arrays: + logical,dimension(klon):: llo2 + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: ikhsmin + + real(kind=kind_phys):: zhsk,zttest,zqtest,zbuo,zmftop + real(kind=kind_phys),dimension(klon):: zcond,zph,zhsmin + real(kind=kind_phys),dimension(klon,klev):: ztenwb,zqenwb + +!---------------------------------------------------------------------- + +! 1. set default values for downdrafts +! --------------------------------- + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo +!---------------------------------------------------------------------- + +! 2. determine level of free sinking: +! downdrafts shall start at model level of minimum +! of saturation moist static energy or below +! respectively + +! for every point and proceed as follows: + +! (1) determine level of minimum of hs +! (2) determine wet bulb environmental t and q +! (3) do mixing with cumulus cloud air +! (4) check for negative buoyancy +! (5) if buoyancy>0 repeat (2) to (4) for next +! level below + +! the assumption is that air of downdrafts is mixture +! of 50% cloud air + 50% environmental air at wet bulb +! temperature (i.e. which became saturated due to +! evaporation of rain and cloud water) +! ---------------------------------------------------- + do jk=3,klev-2 + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) + if(zhsk .lt. zhsmin(jl)) then + zhsmin(jl) = zhsk + ikhsmin(jl)= jk + end if + end do + end do + + + ike=klev-3 + do jk=3,ike + +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* +! ------------------------------------------- + is=0 + do jl=1,klon + ztenwb(jl,jk)=ptenh(jl,jk) + zqenwb(jl,jk)=pqenh(jl,jk) + zph(jl)=paph(jl,jk) + llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & + & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) + if(llo2(jl))then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + ik=jk + icall=2 + call cuadjtqn & + & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) + +! 2.2 do mixing of cumulus and environmental air +! and check for negative buoyancy. +! then set values for downdraft at lfs. +! ---------------------------------------- + do jl=1,klon + if(llo2(jl)) then + zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) + zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) + zbuo=zttest*(1.+vtmpc1 *zqtest)- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) + zmftop=-cmfdeps*pmfub(jl) + if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then + kdtop(jl)=jk + lddraf(jl)=.true. + ptd(jl,jk)=zttest + pqd(jl,jk)=zqtest + pmfd(jl,jk)=zmftop + pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) + pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) + prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) + endif + endif + enddo + + enddo + + return + end subroutine cudlfsn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- +!********************************************** +! subroutine cuddrafn +!********************************************** + subroutine cuddrafn & + & ( klon, klev, lddraf & + & , ptenh, pqenh, puen, pven & + & , pgeo, pgeoh, paph, prfl & + & , ptd, pqd, pud, pvd, pmfu & + & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) + +! this routine calculates cumulus downdraft descent + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce the vertical profiles for cumulus downdrafts +! (i.e. t,q,u and v and fluxes) + +! interface +! --------- + +! this routine is called from *cumastr*. +! input is t,q,p,phi,u,v at half levels. +! it returns fluxes of s,q and evaporation rate +! and u,v at levels where downdraft occurs + +! method. +! -------- +! calculate moist descent for entraining/detraining plume by +! a) moving air dry-adiabatically to next level below and +! b) correcting for evaporation to obtain saturated state. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels + +! input parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pgeo* geopotential m2/s2 +! *paph* provisional pressure on half levels pa +! *pmfu* massflux updrafts kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! externals +! --------- +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!---------------------------------------------------------------------- + implicit none + +!--- input arguments: + integer,intent(in)::klon + logical,intent(in),dimension(klon):: lddraf + + integer,intent(in)::klev + + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptd,pqd,pud,pvd + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfd,pmfds,pmfdq,pdmfdp + +!--- output arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfdde_rate + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: llo2 + + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: itopde + + real(kind=kind_phys):: zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys):: zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + real(kind=kind_phys),dimension(klon):: zdmfen,zdmfde,zcond,zoentr,zbuoy,zph + +!---------------------------------------------------------------------- +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment/detrainment rates, +! including organized entrainment dependent on +! negative buoyancy and assuming +! linear decrease of massflux in pbl +! (b) doing moist descent - evaporative cooling +! and moistening is calculated in *cuadjtq* +! (c) checking for negative buoyancy and +! specifying final t,q,u,v and downward fluxes +! ------------------------------------------------- + do jl=1,klon + zoentr(jl)=0. + zbuoy(jl)=0. + zdmfen(jl)=0. + zdmfde(jl)=0. + enddo + + do jk=klev,1,-1 + do jl=1,klon + pmfdde_rate(jl,jk) = 0. + if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk + end do + end do + + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.gt.itopde(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde(jl))* & + & (paph(jl,jk)-paph(jl,jk-1))/ & + & (paph(jl,klev+1)-paph(jl,itopde(jl))) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.le.itopde(jl)) then + zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) + zdmfen(jl)=zdmfen(jl)+zzentr + zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) + zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & + & (pmfd(jl,jk-1)-zdmfde(jl))) + zdmfen(jl)=min(zdmfen(jl),0.) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& + & pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + endif + enddo + + ik=jk + icall=2 + call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) + + do jl=1,klon + if(llo2(jl)) then + zcond(jl)=zcond(jl)-pqd(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) + zbuo=zbuo-ptd(jl,jk)*zrain + endif + if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + zbuo=0. + endif + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp + +! compute organized entrainment for use at next level + zbuoyz=zbuo/ptenh(jl,jk) + zbuoyz=min(zbuoyz,0.0) + zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) + zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz + zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + pmfdde_rate(jl,jk) = -zdmfde(jl) + endif + enddo + + enddo + + return + end subroutine cuddrafn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ptenh, pqenh & + & , paph, pap, pgeoh, lndj, ldcum & + & , kcbot, kctop, kdtop, ktopm2 & + & , ktype, lddraf & + & , pmfu, pmfd, pmfus, pmfds & + & , pmfuq, pmfdq, pmful, plude & + & , pdmfup, pdmfdp, pdpmel, plglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 + +! purpose +! ------- + +! this routine does the final calculation of convective +! fluxes in the cloud layer and in the subcloud layer + +! interface +! --------- +! this routine is called from *cumastr*. + + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level +! *kdtop* top level of downdrafts + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptsphy* time step for the physics s +! *pten* provisional environment temperature (t+1) k +! *pqen* provisional environment spec. humidity (t+1) kg/kg +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *paph* provisional pressure on half levels pa +! *pap* provisional pressure on full levels pa +! *pgeoh* geopotential on half levels m2/s2 + +! updated parameters (integer): + +! *ktype* set to zero if ldcum=.false. + +! updated parameters (logical): + +! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) + if ( llddraf .and.jk.ge.kdtop(jl)) then + pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) + else + pmfd(jl,jk) = 0. + pmfds(jl,jk) = 0. + pmfdq(jl,jk) = 0. + pdmfdp(jl,jk-1) = 0. + end if + if ( llddraf .and. pmfd(jl,jk) < 0. .and. & + abs(pmfd(jl,ikb)) < 1.e-20 ) then + idbas(jl) = jk + end if + else + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pmful(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + endif + enddo + enddo + + do jl=1,klon + pmflxr(jl,klev+1) = 0. + pmflxs(jl,klev+1) = 0. + end do + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + ik=ikb+1 + zzp=((paph(jl,klev+1)-paph(jl,ik))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,ik)=pmfu(jl,ikb)*zzp + pmfus(jl,ik)=(pmfus(jl,ikb)- & + & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp + pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp + pmful(jl,ik)=0. + endif + enddo + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then + ikb=kcbot(jl)+1 + zzp=((paph(jl,klev+1)-paph(jl,jk))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,jk)=pmfu(jl,ikb)*zzp + pmfus(jl,jk)=pmfus(jl,ikb)*zzp + pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp + pmful(jl,jk)=0. + endif + ik = idbas(jl) + llddraf = lddraf(jl) .and. jk > ik .and. ik < klev + if ( llddraf .and. ik == kcbot(jl)+1 ) then + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + pmfd(jl,jk) = pmfd(jl,ik)*zzp + pmfds(jl,jk) = pmfds(jl,ik)*zzp + pmfdq(jl,jk) = pmfdq(jl,ik)*zzp + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + end if + enddo + enddo +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip +! ------------------------------- + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then + zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) + pdpmel(jl,jk)=zsnmlt + pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) + endif + zalfaw=foealfa(pten(jl,jk)) + ! + ! No liquid precipitation above melting level + ! + if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then + plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zalfaw = 0. + end if + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) + pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) + if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then + pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdpmel(jl,jk) =0.0 + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + endif + enddo + enddo + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl)) then + zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) + if(zrfl.gt.1.e-20) then + zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & + & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & + & zrfl/zcucov)**0.5777* & + & (paph(jl,jk+1)-paph(jl,jk)) + zrnew=zrfl-zdrfl1 + zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & + & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) + zrnew=max(zrnew,zrmin) + zrfln=max(zrnew,0.) + zdrfl=min(0.,zrfln-zrfl) + zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) + zalfaw=foealfa(pten(jl,jk)) + if ( pten(jl,jk) < tmelt ) zalfaw = 0. + zpdr=zalfaw*pdmfdp(jl,jk) + zpds=(1.-zalfaw)*pdmfdp(jl,jk) + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & + & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom + pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & + & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then + pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) + pmflxr(jl,jk+1) = 0. + pmflxs(jl,jk+1) = 0. + pdpmel(jl,jk) = 0. + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + else + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdmfdp(jl,jk)=0.0 + pdpmel(jl,jk)=0.0 + endif + endif + enddo + enddo + + return + end subroutine cuflxn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & + lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & + pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & + pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum,lddraf + + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: kctop,kdtop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfus,pmfd,pmfds + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfuq,pmfdq,pmful + real(kind=kind_phys),intent(in),dimension(klon,klev):: plglac,plude,pdpmel + real(kind=kind_phys),intent(in),dimension(klon,klev):: pdmfup,pdmfdp + real(kind=kind_phys),intent(in),dimension(klon,klev):: pqen, ptenh,pqenh,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptent,ptenq,pcte + +!--- local variables and arrays: + integer:: jk ,ik ,jl + real(kind=kind_phys):: zalv ,zzp + real(kind=kind_phys),dimension(klon,klev):: zdtdt,zdqdt,zdp + + !* 1.0 SETUP AND INITIALIZATIONS + ! ------------------------- + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do + !----------------------------------------------------------------------- + !* 2.0 COMPUTE TENDENCIES + ! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & + (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & + pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) + zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & + pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & + pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) + end if + end do + end if + end do + !--------------------------------------------------------------- + !* 3.0 UPDATE TENDENCIES + ! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) + ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + end if + end do + end do + + return + end subroutine cudtdqn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: ktype,kcbot,kctop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfd,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pud,pvu,pvd + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenu,ptenv + +!--- local variables and arrays: + integer:: ik,ikb,jk,jl + + real(kind=kind_phys):: zzp,zdtdt + real(kind=kind_Phys),dimension(klon,klev):: zdudt,zdvdt,zdp + real(kind=kind_phys),dimension(klon,klev):: zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv + +! + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zuen(jl,jk) = puen(jl,jk) + zven(jl,jk) = pven(jl,jk) + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do +!---------------------------------------------------------------------- +!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +! ---------------------------------------------- + do jk = ktopm2 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) + zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) + zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) + zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) + end if + end do + end do + ! linear fluxes below cloud + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk > kcbot(jl) ) then + ikb = kcbot(jl) + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp + zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp + zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp + zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp + end if + end do + end do +!---------------------------------------------------------------------- +!* 2.0 COMPUTE TENDENCIES +! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = zdp(jl,jk) * & + (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) + zdvdt(jl,jk) = zdp(jl,jk) * & + (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) + end if + end do + end if + end do +!--------------------------------------------------------------------- +!* 3.0 UPDATE TENDENCIES +! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) + ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) + end if + end do + end do +!---------------------------------------------------------------------- + return + end subroutine cududvn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cuadjtqn & + & (klon, klev, kk, psp, pt, pq, ldflag, kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! purpose. +! -------- +! to produce t,q and l values for cloud ascent + +! interface +! --------- +! this routine is called from subroutines: +! *cond* (t and q at condensation level) +! *cubase* (t and q at condensation level) +! *cuasc* (t and q at cloud levels) +! *cuini* (environmental t and qs values at half levels) +! input are unadjusted t and q values, +! it returns adjusted values of t and q + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kk* level +! *kcall* defines calculation as +! kcall=0 env. t and qs in*cuini* +! kcall=1 condensation in updrafts (e.g. cubase, cuasc) +! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) +! input parameters (real): + +! *psp* pressure pa + +! updated parameters (real): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldflag + integer,intent(in):: kcall,kk,klev + + real(kind=kind_phys),intent(in),dimension(klon):: psp + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pt,pq + +!--- local variables and arrays: + integer:: jl,jk + integer:: isum + + real(kind=kind_phys)::zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf + +!---------------------------------------------------------------------- +! 1. define constants +! ---------------- + zqmax=0.5 + +! 2. calculate condensation and adjust t and q accordingly +! ----------------------------------------------------- + + if ( kcall == 1 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & + (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( zcond > 0. ) then + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk)) * & + exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & + exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( abs(zcond) < 1.e-20 ) zcond1 = 0. + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end if + end do + elseif ( kcall == 2 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + zcond = min(zcond,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end do + else if ( kcall == 0 ) then + do jl = 1,klon + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end do + end if + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 subroutines +!-------------------------------------------------------- + subroutine cubasmcn & + & (klon, klev, klevm1, kk, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, pgeoh, ldcum, ktype, klab, plrain, & + & pmfu, pmfub, kcbot, ptu, & + & pqu, plu, puu, pvu, pmfus, & + & pmfuq, pmful, pdmfup) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +! c.zhang iprc 05/2012 +!***purpose. +! -------- +! this routine calculates cloud base values +! for midlevel convection +!***interface +! --------- +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! it returns cloudbase values for midlevel convection +!***method. +! ------- +! s. tiedtke (1989) +!***externals +! --------- +! none +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: kk,klev,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: puen,pven ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pvu ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype,kcbot + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon):: pmfub + real(kind=kind_phys),intent(out),dimension(klon,klev):: plrain + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful + real(kind=kind_phys),intent(out),dimension(klon,klev):: pdmfup + +!--- local variables and arrays: + integer:: jl,klevp1 + real(kind=kind_phys):: zzzmb + +!-------------------------------------------------------- +!* 1. calculate entrainment and detrainment rates +! ------------------------------------------------------- + do jl=1,klon + if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then + if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & + pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & + & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then + ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& + & *rcpd + pqu(jl,kk+1)=pqen(jl,kk) + plu(jl,kk+1)=0. + zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) + zzzmb=min(zzzmb,cmfcmax) + pmfub(jl)=zzzmb + pmfu(jl,kk+1)=pmfub(jl) + pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) + pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) + pmful(jl,kk+1)=0. + pdmfup(jl,kk+1)=0. + kcbot(jl)=kk + klab(jl,kk+1)=1 + plrain(jl,kk+1)=0.0 + ktype(jl)=3 + end if + end if + end do + return + end subroutine cubasmcn +!--------------------------------------------------------- +! level 4 subroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + +!--- input arguments: + logical,intent(in):: ldwork + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev,kk + integer,intent(in),dimension(klon):: kcbot + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(klon):: pdmfen + real(kind=kind_phys),intent(out),dimension(klon):: pdmfde + +!--- local variables and arrays: + logical:: llo1 + integer:: jl + real(kind=kind_phys):: zdz ,zmf + real(kind=kind_phys),dimension(klon):: zentr + + ! + !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES + ! ------------------------------------------- + if ( ldwork ) then + do jl = 1,klon + pdmfen(jl) = 0. + pdmfde(jl) = 0. + zentr(jl) = 0. + end do + ! + !* 1.1 SPECIFY ENTRAINMENT RATES + ! ------------------------- + do jl = 1, klon + if ( ldcum(jl) ) then + zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg + zmf = pmfu(jl,kk+1)*zdz + llo1 = kk < kcbot(jl) + if ( llo1 ) then + pdmfen(jl) = zentr(jl)*zmf + pdmfde(jl) = 0.75e-4*zmf + end if + end if + end do + end if + end subroutine cuentrn +!-------------------------------------------------------- +! external functions +!------------------------------------------------------ + real(kind=kind_phys) function foealfa(tt) +! foealfa is calculated to distinguish the three cases: +! +! foealfa=1 water phase +! foealfa=0 ice phase +! 0 < foealfa < 1 mixed phase +! +! input : tt = temperature +! + implicit none + real(kind=kind_phys),intent(in):: tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real(kind=kind_phys) function foelhm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real(kind=kind_phys) function foeewm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real(kind=kind_phys) function foedem(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real(kind=kind_phys) function foeldcpm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + +!================================================================================================================= + end module cu_ntiedtke +!================================================================================================================= + diff --git a/phys/physics_mmm/module_libmassv.F90 b/phys/physics_mmm/module_libmassv.F90 new file mode 100644 index 0000000000..60ff9fa022 --- /dev/null +++ b/phys/physics_mmm/module_libmassv.F90 @@ -0,0 +1,91 @@ +!================================================================================================================= + module module_libmassv + + implicit none + + + interface vrec + module procedure vrec_d + module procedure vrec_s + end interface + + interface vsqrt + module procedure vsqrt_d + module procedure vsqrt_s + end interface + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + contains + + +!================================================================================================================= + subroutine vrec_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R8KIND)/x(j) + enddo + + end subroutine vrec_d + +!================================================================================================================= + subroutine vrec_s(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R4KIND)/x(j) + enddo + + end subroutine vrec_s + +!================================================================================================================= + subroutine vsqrt_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_d + +!================================================================================================================= + subroutine vsqrt_s(y,x,n) +!================================================================================================================= + + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j + +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_s + +!================================================================================================================= + end module module_libmassv +!================================================================================================================= diff --git a/phys/physics_mmm/mp_radar.F90 b/phys/physics_mmm/mp_radar.F90 new file mode 100644 index 0000000000..851e5d3f69 --- /dev/null +++ b/phys/physics_mmm/mp_radar.F90 @@ -0,0 +1,677 @@ +!================================================================================================================= + module mp_radar + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: radar_init, & + rayleigh_soak_wetgraupel + +!+---+-----------------------------------------------------------------+ +!..This set of routines facilitates computing radar reflectivity. +!.. This module is more library code whereas the individual microphysics +!.. schemes contains specific details needed for the final computation, +!.. so refer to location within each schemes calling the routine named +!.. rayleigh_soak_wetgraupel. +!.. The bulk of this code originated from Ulrich Blahak (Germany) and +!.. was adapted to WRF by G. Thompson. This version of code is only +!.. intended for use when Rayleigh scattering principles dominate and +!.. is not intended for wavelengths in which Mie scattering is a +!.. significant portion. Therefore, it is well-suited to use with +!.. 5 or 10 cm wavelength like USA NEXRAD radars. +!.. This code makes some rather simple assumptions about water +!.. coating on outside of frozen species (snow/graupel). Fraction of +!.. meltwater is simply the ratio of mixing ratio below melting level +!.. divided by mixing ratio at level just above highest T>0C. Also, +!.. immediately 90% of the melted water exists on the ice's surface +!.. and 10% is embedded within ice. No water is "shed" at all in these +!.. assumptions. The code is quite slow because it does the reflectivity +!.. calculations based on 50 individual size bins of the distributions. +!+---+-----------------------------------------------------------------+ + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + integer,parameter,public:: nrbins = 50 + integer,parameter,public:: slen = 20 + character(len=slen), public:: & + mixingrulestring_s, matrixstring_s, inclusionstring_s, & + hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & + mixingrulestring_g, matrixstring_g, inclusionstring_g, & + hoststring_g, hostmatrixstring_g, hostinclusionstring_g + + complex(kind=R8KIND),public:: m_w_0, m_i_0 + + double precision,dimension(nrbins+1),public:: xxdx + double precision,dimension(nrbins),public:: xxds,xdts,xxdg,xdtg + double precision,parameter,public:: lamda_radar = 0.10 ! in meters + double precision,public:: k_w,pi5,lamda4 + + double precision, dimension(nrbins+1), public:: simpson + double precision, dimension(3), parameter, public:: basis = & + (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) + + real(kind=kind_phys),public,dimension(4):: xcre,xcse,xcge,xcrg,xcsg,xcgg + real(kind=kind_phys),public:: xam_r,xbm_r,xmu_r,xobmr + real(kind=kind_phys),public:: xam_s,xbm_s,xmu_s,xoams,xobms,xocms + real(kind=kind_phys),public:: xam_g,xbm_g,xmu_g,xoamg,xobmg,xocmg + real(kind=kind_phys),public:: xorg2,xosg2,xogg2 + + +!..Single melting snow/graupel particle 90% meltwater on external sfc + character(len=256):: radar_debug + + double precision,parameter,public:: melt_outside_s = 0.9d0 + double precision,parameter,public:: melt_outside_g = 0.9d0 + + + contains + + +!================================================================================================================= + subroutine radar_init + implicit none +!================================================================================================================= + + integer:: n + +!----------------------------------------------------------------------------------------------------------------- + + pi5 = 3.14159*3.14159*3.14159*3.14159*3.14159 + lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar + m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) + m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) + k_w = (abs( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 + + do n = 1, nrbins+1 + simpson(n) = 0.0d0 + enddo + do n = 1, nrbins-1, 2 + simpson(n) = simpson(n) + basis(1) + simpson(n+1) = simpson(n+1) + basis(2) + simpson(n+2) = simpson(n+2) + basis(3) + enddo + + do n = 1, slen + mixingrulestring_s(n:n) = char(0) + matrixstring_s(n:n) = char(0) + inclusionstring_s(n:n) = char(0) + hoststring_s(n:n) = char(0) + hostmatrixstring_s(n:n) = char(0) + hostinclusionstring_s(n:n) = char(0) + mixingrulestring_g(n:n) = char(0) + matrixstring_g(n:n) = char(0) + inclusionstring_g(n:n) = char(0) + hoststring_g(n:n) = char(0) + hostmatrixstring_g(n:n) = char(0) + hostinclusionstring_g(n:n) = char(0) + enddo + + mixingrulestring_s = 'maxwellgarnett' + hoststring_s = 'air' + matrixstring_s = 'water' + inclusionstring_s = 'spheroidal' + hostmatrixstring_s = 'icewater' + hostinclusionstring_s = 'spheroidal' + + mixingrulestring_g = 'maxwellgarnett' + hoststring_g = 'air' + matrixstring_g = 'water' + inclusionstring_g = 'spheroidal' + hostmatrixstring_g = 'icewater' + hostinclusionstring_g = 'spheroidal' + +!..Create bins of snow (from 100 microns up to 2 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.02d0 + do n = 2, nrbins + xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & + * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) + enddo + do n = 1, nrbins + xxds(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdts(n) = xxdx(n+1) - xxdx(n) + enddo + +!..create bins of graupel (from 100 microns up to 5 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.05d0 + do n = 2, nrbins + xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & + * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) + enddo + do n = 1, nrbins + xxdg(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdtg(n) = xxdx(n+1) - xxdx(n) + enddo + + +!.. The calling program must set the m(D) relations and gamma shape +!.. parameter mu for rain, snow, and graupel. Easily add other types +!.. based on the template here. For majority of schemes with simpler +!.. exponential number distribution, mu=0. + + xcre(1) = 1. + xbm_r + xcre(2) = 1. + xmu_r + xcre(3) = 4. + xmu_r + xcre(4) = 7. + xmu_r + do n = 1, 4 + xcrg(n) = wgamma(xcre(n)) + enddo + xorg2 = 1./xcrg(2) + + xcse(1) = 1. + xbm_s + xcse(2) = 1. + xmu_s + xcse(3) = 4. + xmu_s + xcse(4) = 7. + xmu_s + do n = 1, 4 + xcsg(n) = wgamma(xcse(n)) + enddo + xosg2 = 1./xcsg(2) + + xcge(1) = 1. + xbm_g + xcge(2) = 1. + xmu_g + xcge(3) = 4. + xmu_g + xcge(4) = 7. + xmu_g + do n = 1, 4 + xcgg(n) = wgamma(xcge(n)) + enddo + xogg2 = 1./xcgg(2) + + xobmr = 1./xbm_r + xoams = 1./xam_s + xobms = 1./xbm_s + xocms = xoams**xobms + xoamg = 1./xam_g + xobmg = 1./xbm_g + xocmg = xoamg**xobmg + + end subroutine radar_init + +!================================================================================================================= + subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,m_i,lambda,c_back, & + mixingrule,matrix,inclusion,host,hostmatrix,hostinclusion) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*), intent(in):: mixingrule, matrix, inclusion, & + host, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_w, m_i + + double precision, intent(in):: x_g, a_geo, b_geo, fmelt, lambda, meltratio_outside + +!--- output arguments: + double precision,intent(out):: c_back + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: m_core, m_air + + double precision, parameter:: pix=3.1415926535897932384626434d0 + double precision:: d_large, d_g, rhog, x_w, xw_a, fm, fmgrenz, & + volg, vg, volair, volice, volwater, & + meltratio_outside_grenz, mra + +!----------------------------------------------------------------------------------------------------------------- + +!refractive index of air: + m_air = (1.0d0,0.0d0) + +!Limiting the degree of melting --- for safety: + fm = dmax1(dmin1(fmelt, 1.0d0), 0.0d0) +!Limiting the ratio of (melting on outside)/(melting on inside): + mra = dmax1(dmin1(meltratio_outside, 1.0d0), 0.0d0) + +!The relative portion of meltwater melting at outside should increase +!from the given input value (between 0 and 1) +!to 1 as the degree of melting approaches 1, +!so that the melting particle "converges" to a water drop. +!Simplest assumption is linear: + mra = mra + (1.0d0-mra)*fm + + x_w = x_g * fm + + d_g = a_geo * x_g**b_geo + + if(D_g .ge. 1d-12) then + + vg = PIx/6. * D_g**3 + rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) + vg = x_g / rhog + + meltratio_outside_grenz = 1.0d0 - rhog / 1000. + + if (mra .le. meltratio_outside_grenz) then + !..In this case, it cannot happen that, during melting, all the + !.. air inclusions within the ice particle get filled with + !.. meltwater. This only happens at the end of all melting. + volg = vg * (1.0d0 - mra * fm) + + else + !..In this case, at some melting degree fm, all the air + !.. inclusions get filled with meltwater. + fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) + + if (fm .le. fmgrenz) then + !.. not all air pockets are filled: + volg = (1.0 - mra * fm) * vg + else + !..all air pockets are filled with meltwater, now the + !.. entire ice sceleton melts homogeneously: + volg = (x_g - x_w) / 900.0 + x_w / 1000. + endif + + endif + + d_large = (6.0 / pix * volg) ** (1./3.) + volice = (x_g - x_w) / (volg * 900.0) + volwater = x_w / (1000. * volg) + volair = 1.0 - volice - volwater + + !..complex index of refraction for the ice-air-water mixture + !.. of the particle: + m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & + volwater, mixingrule, host, matrix, inclusion, & + hostmatrix, hostinclusion, error) + if (error .ne. 0) then + c_back = 0.0d0 + return + endif + + !..rayleigh-backscattering coefficient of melting particle: + c_back = (abs((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & + * pi5 * d_large**6 / lamda4 + + else + c_back = 0.0d0 + endif + + end subroutine rayleigh_soak_wetgraupel + +!================================================================================================================= + real(kind=kind_phys) function wgamma(y) + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: y + +!----------------------------------------------------------------------------------------------------------------- + + wgamma = exp(gammln(y)) + + end function wgamma + +!================================================================================================================= + real(kind=kind_phys) function gammln(xx) + implicit none +!(C) Copr. 1986-92 Numerical Recipes Software 2.02 +!================================================================================================================= + +!--- inout arguments: + real(kind=kind_phys),intent(in):: xx + +!--- local variables: + integer:: j + + double precision,parameter:: stp = 2.5066282746310005d0 + double precision,dimension(6), parameter:: & + cof = (/76.18009172947146d0, -86.50532032941677d0, & + 24.01409824083091d0, -1.231739572450155d0, & + .1208650973866179d-2, -.5395239384953d-5/) + double precision:: ser,tmp,x,y + +!----------------------------------------------------------------------------------------------------------------- + +!--- returns the value ln(gamma(xx)) for xx > 0. + x = xx + y = x + tmp = x+5.5d0 + tmp = (x+0.5d0)*log(tmp)-tmp + ser = 1.000000000190015d0 + do j = 1,6 + y=y+1.d0 + ser=ser+cof(j)/y + enddo + + gammln=tmp+log(stp*ser/x) + + end function gammln + +!================================================================================================================= + complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & + volice, volwater, mixingrule, host, matrix, & + inclusion, hostmatrix, hostinclusion, cumulerror) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, host, matrix, & + inclusion, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_a, m_i, m_w + + double precision,intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: cumulerror + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: mtmp + + double precision:: vol1, vol2 + +!----------------------------------------------------------------------------------------------------------------- + +!..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be air, ice, or water + cumulerror = 0 + get_m_mix_nested = cmplx(1.0d0,0.0d0) + + if (host .eq. 'air') then + if (matrix .eq. 'air') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volice / MAX(volice+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'air') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'icewater') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'ice') then + + if (matrix .eq. 'ice') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volair+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'ice') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airwater') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + 'air', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'water') then + + if (matrix .eq. 'water') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volice+volair,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'water') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airice') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'none') then + + get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & + volair, volice, volwater, mixingrule, & + matrix, inclusion, error) + cumulerror = cumulerror + error + + else + write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + + if (cumulerror .ne. 0) then + write(radar_debug,*) 'get_m_mix_nested: error encountered' +! call physics_message(radar_debug) + get_m_mix_nested = cmplx(1.0d0,0.0d0) + endif + + end function get_m_mix_nested + +!================================================================================================================= + complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, & + volwater, mixingrule, matrix, inclusion, & + error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, matrix, inclusion + + complex(kind=R8KIND), intent(in):: m_a, m_i, m_w + + double precision, intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: error + +!----------------------------------------------------------------------------------------------------------------- + error = 0 + get_m_mix = cmplx(1.0d0,0.0d0) + + if (mixingrule .eq. 'maxwellgarnett') then + if (matrix .eq. 'ice') then + get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & + m_i, m_a, m_w, inclusion, error) + elseif (matrix .eq. 'water') then + get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & + m_w, m_a, m_i, inclusion, error) + elseif (matrix .eq. 'air') then + get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & + m_a, m_w, m_i, inclusion, error) + else + write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix +! call physics_message(radar_debug) + error = 1 + endif + + else + write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule +! call physics_message(radar_debug) + error = 2 + endif + + if (error .ne. 0) then + write(radar_debug,*) 'GET_M_MIX: error encountered' +! call physics_message(radar_debug) + endif + + end function get_m_mix + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & + m1, m2, m3, inclusion, error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: inclusion + + complex(kind=R8KIND),intent(in):: m1,m2,m3 + + double precision,intent(in):: vol1,vol2,vol3 + + +!--- output arguments: + integer,intent(out):: error + +!--- local variables: + complex(kind=R8KIND) :: beta2, beta3, m1t, m2t, m3t + +!----------------------------------------------------------------------------------------------------------------- + + error = 0 + + if (dabs(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & + 'partial volume fractions is not 1...ERROR' +! call physics_message(radar_debug) + m_complex_maxwellgarnett = CMPLX(-999.99d0,-999.99d0) + error = 1 + return + endif + + m1t = m1**2 + m2t = m2**2 + m3t = m3**2 + + if (inclusion .eq. 'spherical') then + beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) + beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) + elseif (inclusion .eq. 'spheroidal') then + beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) + beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) + else + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion +! call physics_message(radar_debug) + m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND) + error = 1 + return + endif + + m_complex_maxwellgarnett = sqrt(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & + (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) + + end function m_complex_maxwellgarnett + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_water_ray(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive Index of Water as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C +!after Ray (1972) + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision,parameter:: pix=3.1415926535897932384626434d0 + double precision:: epsinf,epss,epsr,epsi + double precision:: alpha,lambdas,sigma,nenner + complex(kind=R8KIND),parameter:: i = (0d0,1d0) + +!----------------------------------------------------------------------------------------------------------------- + + epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T + epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & + + 1.190d-5 * (T - 25.0)*(T - 25.0) & + - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) + alpha = -16.8129d0/(T+273.16) + 0.0609265d0 + lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 + + nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & + + (lambdas/lambda)**(2d0-2d0*alpha) + epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * sin(alpha*PIx*0.5)+1d0)) / nenner + epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * cos(alpha*PIx*0.5)+0d0)) / nenner & + + lambda*1.25664/1.88496 + + m_complex_water_ray = sqrt(cmplx(epsr,-epsi)) + + end function m_complex_water_ray + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_ice_maetzler(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive index of ice as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.0001,30] m; T in [-250.0,0.0] C +!Original comment from the Matlab-routine of Prof. Maetzler: +!Function for calculating the relative permittivity of pure ice in +!the microwave region, according to C. Maetzler, "Microwave +!properties of ice and snow", in B. Schmitt et al. (eds.) Solar +!System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer +!Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: +!TK = temperature (K), range 20 to 273.15 +!f = frequency in GHz, range 0.01 to 3000 + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision:: f,c,tk,b1,b2,b,deltabeta,betam,beta,theta,alfa + +!----------------------------------------------------------------------------------------------------------------- + + c = 2.99d8 + tk = t + 273.16 + f = c / lambda * 1d-9 + + b1 = 0.0207 + b2 = 1.16d-11 + b = 335.0d0 + deltabeta = exp(-10.02 + 0.0364*(tk-273.16)) + betam = (b1/tk) * ( exp(b/tk) / ((exp(b/tk)-1)**2) ) + b2*f*f + beta = betam + deltabeta + theta = 300. / tk - 1. + alfa = (0.00504d0 + 0.0062d0*theta) * exp(-22.1d0*theta) + m_complex_ice_maetzler = 3.1884 + 9.1e-4*(tk-273.16) + m_complex_ice_maetzler = m_complex_ice_maetzler & + + cmplx(0.0d0, (alfa/f + beta*f)) + m_complex_ice_maetzler = sqrt(conjg(m_complex_ice_maetzler)) + + end function m_complex_ice_maetzler + +!================================================================================================================= + end module mp_radar +!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6.F90 b/phys/physics_mmm/mp_wsm6.F90 new file mode 100644 index 0000000000..ec2d1dca3c --- /dev/null +++ b/phys/physics_mmm/mp_wsm6.F90 @@ -0,0 +1,2449 @@ +!================================================================================================================= + module mp_wsm6 + use ccpp_kind_types,only: kind_phys + use module_libmassv,only: vrec,vsqrt + + use mp_radar + + implicit none + private + public:: mp_wsm6_run, & + mp_wsm6_init, & + mp_wsm6_finalize, & + refl10cm_wsm6 + + real(kind=kind_phys),parameter,private:: dtcldcr = 120. ! maximum time step for minor loops + real(kind=kind_phys),parameter,private:: n0r = 8.e6 ! intercept parameter rain +!real(kind=kind_phys),parameter,private:: n0g = 4.e6 ! intercept parameter graupel + real(kind=kind_phys),parameter,private:: avtr = 841.9 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: bvtr = 0.8 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + real(kind=kind_phys),parameter,private:: peaut = .55 ! collection efficiency + real(kind=kind_phys),parameter,private:: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + real(kind=kind_phys),parameter,private:: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + real(kind=kind_phys),parameter,private:: avts = 11.72 ! a constant for terminal velocity of snow + real(kind=kind_phys),parameter,private:: bvts = .41 ! a constant for terminal velocity of snow +!real(kind=kind_phys),parameter,private:: avtg = 330. ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: bvtg = 0.8 ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: deng = 500. ! density of graupel ! set later with hail_opt + real(kind=kind_phys),parameter,private:: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain + real(kind=kind_phys),parameter,private:: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow +!real(kind=kind_phys),parameter,private:: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel + real(kind=kind_phys),parameter,private:: dicon = 11.9 ! constant for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: pfrz1 = 100. ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: pfrz2 = 0.66 ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg + real(kind=kind_phys),parameter,private:: eacrc = 1.0 ! Snow/cloud-water collection efficiency + real(kind=kind_phys),parameter,private:: dens = 100.0 ! Density of snow + real(kind=kind_phys),parameter,private:: qs0 = 6.e-4 ! threshold amount for aggretion to occur + + real(kind=kind_phys),parameter,public :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) + real(kind=kind_phys),parameter,public :: n0s = 2.e6 ! temperature dependent intercept parameter snow + real(kind=kind_phys),parameter,public :: alpha = .12 ! .122 exponen factor for n0s + + real(kind=kind_phys),save:: & + qc0,qck1, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + bvtr6,g6pbr, & + precr1,precr2,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & + xlv1,pacrc,pi, & + bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & + g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & + precg1,precg2,pidn0g, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max + + real(kind=kind_phys),public,save:: pidn0s,pidnc + + + contains + + +!================================================================================================================= +!>\section arg_table_mp_wsm6_init +!!\html\include mp_wsm6_init.html +!! + subroutine mp_wsm6_init(den0,denr,dens,cl,cpv,hail_opt,errmsg,errflg) +!================================================================================================================= + +!input arguments: + integer,intent(in):: hail_opt ! RAS + real(kind=kind_phys),intent(in):: den0,denr,dens,cl,cpv + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + +! RAS13.1 define graupel parameters as graupel-like or hail-like, +! depending on namelist option + if(hail_opt .eq. 1) then !Hail! + n0g = 4.e4 + deng = 700. + avtg = 285.0 + bvtg = 0.8 + lamdagmax = 2.e4 + else !Graupel! + n0g = 4.e6 + deng = 500 + avtg = 330.0 + bvtg = 0.8 + lamdagmax = 6.e4 + endif +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + bvtr6 = 6.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g6pbr = rgmma(bvtr6) + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + pacrc = pi*n0s*avts*g3pbs*.25*eacrc +! + bvtg1 = 1.+bvtg + bvtg2 = 2.5+.5*bvtg + bvtg3 = 3.+bvtg + bvtg4 = 4.+bvtg + g1pbg = rgmma(bvtg1) + g3pbg = rgmma(bvtg3) + g4pbg = rgmma(bvtg4) + pacrg = pi*n0g*avtg*g3pbg*.25 + g5pbgo2 = rgmma(bvtg2) + pvtg = avtg*g4pbg/6. + precg1 = 2.*pi*n0g*.78 + precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 + pidn0g = pi*deng*n0g +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rslopegmax = 1./lamdagmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rslopegbmax = rslopegmax ** bvtg + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rslopeg2max = rslopegmax * rslopegmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax + rslopeg3max = rslopeg2max * rslopegmax + +!+---+-----------------------------------------------------------------+ +!.. Set these variables needed for computing radar reflectivity. These +!.. get used within radar_init to create other variables used in the +!.. radar module. + xam_r = PI*denr/6. + xbm_r = 3. + xmu_r = 0. + xam_s = PI*dens/6. + xbm_s = 3. + xmu_s = 0. + xam_g = PI*deng/6. + xbm_g = 3. + xmu_g = 0. + + call radar_init + + errmsg = 'mp_wsm6_init OK' + errflg = 0 + + end subroutine mp_wsm6_init + +!================================================================================================================= +!>\section arg_table_mp_wsm6_finalize +!!\html\include mp_wsm6_finalize.html +!! + subroutine mp_wsm6_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_finalize OK' + errflg = 0 + + end subroutine mp_wsm6_finalize + +!================================================================================================================= +!>\section arg_table_mp_wsm6_run +!!\html\include mp_wsm6_run.html +!! + subroutine mp_wsm6_run(t,q,qc,qi,qr,qs,qg,den,p,delz,delt, & + g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin,xls, & + xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,sr,snow,snowncv,graupel, & + graupelncv,rainprod2d,evapprod2d, & + its,ite,kts,kte,errmsg,errflg & + ) +!=================================================================================================================! +! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! All production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM6 cloud scheme +! +! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) +! Summer 2003 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2004 +! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! add hail option from afwa, aug 2014 +! ==> switch graupel or hail by changing no, den, fall vel. +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan +! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. +! Juang and Hong (JH, 2010) Mon. Wea. Rev. +! + +!input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:,:):: & + den, & + p, & + delz + real(kind=kind_phys),intent(in):: & + delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + xls, & + xlv0, & + xlf0, & + cliq, & + cice, & + psat, & + denr + +!inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:,:):: & + t + real(kind=kind_phys),intent(inout),dimension(its:,:):: & + q, & + qc, & + qi, & + qr, & + qs, & + qg + real(kind=kind_phys),intent(inout),dimension(its:):: & + rain, & + rainncv, & + sr + + real(kind=kind_phys),intent(inout),dimension(its:),optional:: & + snow, & + snowncv + + real(kind=kind_phys),intent(inout),dimension(its:),optional:: & + graupel, & + graupelncv + + real(kind=kind_phys),intent(inout),dimension(its:,:),optional:: & + rainprod2d, & + evapprod2d + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables and arrays: + real(kind=kind_phys),dimension(its:ite,kts:kte,3):: & + rh, & + qsat, & + rslope, & + rslope2, & + rslope3, & + rslopeb, & + qrs_tmp, & + falk, & + fall, & + work1 + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + fallc, & + falkc, & + work1c, & + work2c, & + workr, & + worka + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + den_tmp, & + delz_tmp + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + pigen, & + pidep, & + pcond, & + prevp, & + psevp, & + pgevp, & + psdep, & + pgdep, & + praut, & + psaut, & + pgaut, & + piacr, & + pracw, & + praci, & + pracs, & + psacw, & + psaci, & + psacr, & + pgacw, & + pgaci, & + pgacr, & + pgacs, & + paacw, & + psmlt, & + pgmlt, & + pseml, & + pgeml + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + qsum, & + xl, & + cpm, & + work2, & + denfac, & + xni, & + denqrs1, & + denqrs2, & + denqrs3, & + denqci, & + n0sfac + real(kind=kind_phys),dimension(its:ite):: & + delqrs1, & + delqrs2, & + delqrs3, & + delqi + real(kind=kind_phys),dimension(its:ite):: & + tstepsnow, & + tstepgraup + integer,dimension(its:ite):: & + mstep, & + numdt + logical,dimension(its:ite):: flgcld + real(kind=kind_phys):: & + cpmcal, xlcal, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & + coeres, supsat, dtcld, xmi, eacrs, satdt, & + qimax, diameter, xni0, roqi0, & + fallsum, fallsum_qsi, fallsum_qg, & + vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & + xlwork2, factor, source, value, & + xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 + real(kind=kind_phys):: vt2ave + real(kind=kind_phys):: holdc, holdci + integer:: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim + +!Temporaries used for inlining fpvs function + real(kind=kind_phys):: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp + +! variables for optimization + real(kind=kind_phys),dimension(its:ite):: dvec1,tvec1 + real(kind=kind_phys):: temp + +!----------------------------------------------------------------------------------------------------------------- + +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! Optimizatin : A**B => exp(log(A)*(B)) +! + diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & + /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! +! + idim = ite-its+1 + kdim = kte-kts+1 +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qc(i,k) = max(qc(i,k),0.0) + qr(i,k) = max(qr(i,k),0.0) + qi(i,k) = max(qi(i,k),0.0) + qs(i,k) = max(qs(i,k),0.0) + qg(i,k) = max(qg(i,k),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the surface rain, snow, graupel +! + do i = its, ite + rainncv(i) = 0. + if(present(snowncv) .and. present(snow)) snowncv(i) = 0. + if(present(graupelncv) .and. present(graupel)) graupelncv(i) = 0. + sr(i) = 0. +! new local array to catch step snow and graupel + tstepsnow(i) = 0. + tstepgraup(i) = 0. + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! +! do k = kts, kte +! do i = its, ite +! denfac(i,k) = sqrt(den0/den(i,k)) +! enddo +! enddo + do k = kts, kte + do i = its,ite + dvec1(i) = den(i,k) + enddo + call vrec(tvec1,dvec1,ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + call vsqrt(dvec1,tvec1,ite-its+1) + do i = its,ite + denfac(i,k) = dvec1(i) + enddo + enddo +! +! Inline expansion for fpvs +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qsat(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + prevp(i,k) = 0. + psdep(i,k) = 0. + pgdep(i,k) = 0. + praut(i,k) = 0. + psaut(i,k) = 0. + pgaut(i,k) = 0. + pracw(i,k) = 0. + praci(i,k) = 0. + piacr(i,k) = 0. + psaci(i,k) = 0. + psacw(i,k) = 0. + pracs(i,k) = 0. + psacr(i,k) = 0. + pgacw(i,k) = 0. + paacw(i,k) = 0. + pgaci(i,k) = 0. + pgacr(i,k) = 0. + pgacs(i,k) = 0. + pigen(i,k) = 0. + pidep(i,k) = 0. + pcond(i,k) = 0. + psmlt(i,k) = 0. + pgmlt(i,k) = 0. + pseml(i,k) = 0. + pgeml(i,k) = 0. + psevp(i,k) = 0. + pgevp(i,k) = 0. + falk(i,k,1) = 0. + falk(i,k,2) = 0. + falk(i,k,3) = 0. + fall(i,k,1) = 0. + fall(i,k,2) = 0. + fall(i,k,3) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- + do k = kts, kte + do i = its, ite + temp = (den(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + workr(i,k) = work1(i,k,1) + qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) + if( qsum(i,k) .gt. 1.e-15 ) then + worka(i,k) = (work1(i,k,2)*qs(i,k) + work1(i,k,3)*qg(i,k)) & + / qsum(i,k) + else + worka(i,k) = 0. + endif + denqrs1(i,k) = den(i,k)*qr(i,k) + denqrs2(i,k) = den(i,k)*qs(i,k) + denqrs3(i,k) = den(i,k)*qg(i,k) + if(qr(i,k).le.0.0) workr(i,k) = 0.0 + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & + delqrs1,dtcld,1,1) + call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & + denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) + do k = kts, kte + do i = its, ite + qr(i,k) = max(denqrs1(i,k)/den(i,k),0.) + qs(i,k) = max(denqrs2(i,k)/den(i,k),0.) + qg(i,k) = max(denqrs3(i,k)/den(i,k),0.) + fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) + fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) + fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) + enddo + enddo + do i = its, ite + fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld + fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld + enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c) then +!--------------------------------------------------------------- +! psmlt: melting of snow [HL A33] [RH83 A25] +! (T>T0: S->R) +!--------------------------------------------------------------- + xlf = xlf0 + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + if(qs(i,k).gt.0.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2) & + +precs2*work2(i,k)*coeres)/den(i,k) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qs(i,k)/mstep(i)),0.) + qs(i,k) = qs(i,k) + psmlt(i,k) + qr(i,k) = qr(i,k) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif +!--------------------------------------------------------------- +! pgmlt: melting of graupel [HL A23] [LFO 47] +! (T>T0: G->R) +!--------------------------------------------------------------- + if(qg(i,k).gt.0.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & + *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres)/den(i,k) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & + -qg(i,k)/mstep(i)),0.) + qg(i,k) = qg(i,k) + pgmlt(i,k) + qr(i,k) = qr(i,k) - pgmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) + endif + endif + enddo + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + do k = kte, kts, -1 + do i = its, ite + if(qi(i,k).le.0.) then + work1c(i,k) = 0. + else + xmi = den(i,k)*qi(i,k)/xni(i,k) + diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) + endif + enddo + enddo +! +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 + do i = its, ite + denqci(i,k) = den(i,k)*qi(i,k) + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qi(i,k) = max(denqci(i,k)/den(i,k),0.) + enddo + enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) + fallsum_qsi = fall(i,kts,2)+fallc(i,kts) + fallsum_qg = fall(i,kts,3) + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) + rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) + endif + if(fallsum_qsi.gt.0.) then + tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + + tstepsnow(i) + if(present(snowncv) .and. present(snow)) then + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + + snowncv(i) + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + endif + endif + if(fallsum_qg.gt.0.) then + tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & + + tstepgraup(i) + if(present (graupelncv) .and. present (graupel)) then + graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & + + graupelncv(i) + graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) + endif + endif + if(present (snowncv)) then + if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(rainncv(i)+1.e-12) + else + if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) + endif + enddo +! +!--------------------------------------------------------------- +! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] +! (T>T0: I->C) +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + xlf = xls-xl(i,k) + if(supcol.lt.0.) xlf = xlf0 + if(supcol.lt.0.and.qi(i,k).gt.0.) then + qc(i,k) = qc(i,k) + qi(i,k) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qi(i,k) + qi(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [HL A45] +! (T<-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.40..and.qc(i,k).gt.0.) then + qi(i,k) = qi(i,k) + qc(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qc(i,k) + qc(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [HL A44] +! (T0>T>-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qc(i,k).gt.qmin) then +! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & +! * den(i,k)/denr/xncr*qc(i,k)**2*dtcld,qc(i,k)) + supcolt=min(supcol,50.) + pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & + * den(i,k)/denr/xncr*qc(i,k)*qc(i,k)*dtcld,qc(i,k)) + qi(i,k) = qi(i,k) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qc(i,k) = qc(i,k)-pfrzdtc + endif +!--------------------------------------------------------------- +! pgfrz: freezing of rain water [HL A20] [LFO 45] +! (TG) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qr(i,k).gt.0.) then +! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & +! * (exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & +! * rslope(i,k,1)*dtcld,qr(i,k)) + temp = rslope3(i,k,1) + temp = temp*temp*rslope(i,k,1) + supcolt=min(supcol,50.) + pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & + *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & + qr(i,k)) + qg(i,k) = qg(i,k) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qr(i,k) = qr(i,k)-pfrzdtr + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! update the slope parameters for microphysics computation +! + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +!------------------------------------------------------------------ +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qsat(i,k,1)) + work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qsat(i,k,2)) + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qsat(i,k,1) + satdt = supsat/dtcld +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qc(i,k).gt.qc0) then + praut(i,k) = qck1*qc(i,k)**(7./3.) + praut(i,k) = min(praut(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [LFO 51] +! (C->R) +!--------------------------------------------------------------- + if(qr(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qr(i,k).gt.0.) then + coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) + prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & + + precr2*work2(i,k)*coeres)/work1(i,k,1) + if(prevp(i,k).lt.0.) then + prevp(i,k) = max(prevp(i,k),-qr(i,k)/dtcld) + prevp(i,k) = max(prevp(i,k),satdt/2) + else + prevp(i,k) = min(prevp(i,k),satdt/2) + endif + endif + enddo + enddo +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and RH84 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + supsat = max(q(i,k),qmin)-qsat(i,k,2) + satdt = supsat/dtcld + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! * max(qi(i,k),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) +! + xmi = den(i,k)*qi(i,k)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) + vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) + vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) + qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) + if(qsum(i,k) .gt. 1.e-15) then + vt2ave=(vt2s*qs(i,k)+vt2g*qg(i,k))/(qsum(i,k)) + else + vt2ave=0. + endif + if(supcol.gt.0.and.qi(i,k).gt.qmin) then + if(qr(i,k).gt.qcrmin) then +!------------------------------------------------------------- +! praci: accretion of cloud ice by rain [HL A15] [LFO 25] +! (TR) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & + + diameter**2*rslope(i,k,1) + praci(i,k) = pi*qi(i,k)*n0r*abs(vt2r-vt2i)*acrfac/4. +! reduce collection efficiency (suggested by B. Wilt) + praci(i,k) = praci(i,k)*min(max(0.0,qr(i,k)/qi(i,k)),1.)**2 + praci(i,k) = min(praci(i,k),qi(i,k)/dtcld) +!------------------------------------------------------------- +! piacr: accretion of rain by cloud ice [HL A19] [LFO 26] +! (TS or R->G) +!------------------------------------------------------------- + piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & + * g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & + * rslopeb(i,k,1)/24./den(i,k) +! reduce collection efficiency (suggested by B. Wilt) + piacr(i,k) = piacr(i,k)*min(max(0.0,qi(i,k)/qr(i,k)),1.)**2 + piacr(i,k) = min(piacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! psaci: accretion of cloud ice by snow [HDC 10] +! (TS) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin) then + acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & + + diameter**2*rslope(i,k,2) + psaci(i,k) = pi*qi(i,k)*eacrs*n0s*n0sfac(i,k) & + * abs(vt2ave-vt2i)*acrfac/4. + psaci(i,k) = min(psaci(i,k),qi(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgaci: accretion of cloud ice by graupel [HL A17] [LFO 41] +! (TG) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin) then + egi = exp(0.07*(-supcol)) + acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & + + diameter**2*rslope(i,k,3) + pgaci(i,k) = pi*egi*qi(i,k)*n0g*abs(vt2ave-vt2i)*acrfac/4. + pgaci(i,k) = min(pgaci(i,k),qi(i,k)/dtcld) + endif + endif +!------------------------------------------------------------- +! psacw: accretion of cloud water by snow [HL A7] [LFO 24] +! (TS, and T>=T0: C->R) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qs(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacw: accretion of cloud water by graupel [HL A6] [LFO 40] +! (TG, and T>=T0: C->R) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qg(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!------------------------------------------------------------- +! paacw: accretion of cloud water by averaged snow/graupel +! (TG or S, and T>=T0: C->R) +!------------------------------------------------------------- + if(qsum(i,k) .gt. 1.e-15) then + paacw(i,k) = (qs(i,k)*psacw(i,k)+qg(i,k)*pgacw(i,k)) & + /(qsum(i,k)) + endif +!------------------------------------------------------------- +! pracs: accretion of snow by rain [HL A11] [LFO 27] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then + if(supcol.gt.0) then + acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & + + 2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & + + .5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) + pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & + * (dens/den(i,k))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + pracs(i,k) = pracs(i,k)*min(max(0.0,qr(i,k)/qs(i,k)),1.)**2 + pracs(i,k) = min(pracs(i,k),qs(i,k)/dtcld) + endif +!------------------------------------------------------------- +! psacr: accretion of rain by snow [HL A10] [LFO 28] +! (TS or R->G) (T>=T0: enhance melting of snow) +!------------------------------------------------------------- + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & + + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & + +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) + psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & + * (denr/den(i,k))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + psacr(i,k) = psacr(i,k)*min(max(0.0,qs(i,k)/qr(i,k)),1.)**2 + psacr(i,k) = min(psacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacr: accretion of rain by graupel [HL A12] [LFO 42] +! (TG) (T>=T0: enhance melting of graupel) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & + + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & + + .5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) + pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & + * acrfac +! reduce collection efficiency (suggested by B. Wilt) + pgacr(i,k) = pgacr(i,k)*min(max(0.0,qg(i,k)/qr(i,k)),1.)**2 + pgacr(i,k) = min(pgacr(i,k),qr(i,k)/dtcld) + endif +! +!------------------------------------------------------------- +! pgacs: accretion of snow by graupel [HL A13] [LFO 29] +! (S->G): This process is eliminated in V3.0 with the +! new combined snow/graupel fall speeds +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qs(i,k).gt.qcrmin) then + pgacs(i,k) = 0. + endif + if(supcol.le.0) then + xlf = xlf0 +!------------------------------------------------------------- +! pseml: enhanced melting of snow by accretion of water [HL A34] +! (T>=T0: S->R) +!------------------------------------------------------------- + if(qs(i,k).gt.0.) & + pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & + / xlf,-qs(i,k)/dtcld),0.) +!------------------------------------------------------------- +! pgeml: enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] +! (T>=T0: G->R) +!------------------------------------------------------------- + if(qg(i,k).gt.0.) & + pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & + / xlf,-qg(i,k)/dtcld),0.) + endif + if(supcol.gt.0) then +!------------------------------------------------------------- +! pidep: deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qi(i,k).gt.0.and.ifsat.ne.1) then + pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) + supice = satdt-prevp(i,k) + if(pidep(i,k).lt.0.) then + pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) + pidep(i,k) = max(pidep(i,k),-qi(i,k)/dtcld) + else + pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (TS or S->V) +!------------------------------------------------------------- + if(qs(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & + + precs2*work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k) + if(psdep(i,k).lt.0.) then + psdep(i,k) = max(psdep(i,k),-qs(i,k)/dtcld) + psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) + else + psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & + ifsat = 1 + endif +!------------------------------------------------------------- +! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] +! (TG or G->V) +!------------------------------------------------------------- + if(qg(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & + + precg2*work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) + if(pgdep(i,k).lt.0.) then + pgdep(i,k) = max(pgdep(i,k),-qg(i,k)/dtcld) + pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) + else + pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & + abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) + xni0 = 1.e3*exp(0.1*supcol) + roqi0 = 4.92e-11*xni0**1.33 + pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qi(i,k),0.))/dtcld) + pigen(i,k) = min(min(pigen(i,k),satdt),supice) + endif +! +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qi(i,k).gt.0.) then + qimax = roqimax/den(i,k) + psaut(i,k) = max(0.,(qi(i,k)-qimax)/dtcld) + endif +! +!------------------------------------------------------------- +! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.0.) then + alpha2 = 1.e-3*exp(0.09*(-supcol)) + pgaut(i,k) = min(max(0.,alpha2*(qs(i,k)-qs0)),qs(i,k)/dtcld) + endif + endif +! +!------------------------------------------------------------- +! psevp: evaporation of melting snow [HL A35] [RH83 A27] +! (T>=T0: S->V) +!------------------------------------------------------------- + if(supcol.lt.0.) then + if(qs(i,k).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & + * rslope2(i,k,2)+precs2*work2(i,k) & + * coeres)/work1(i,k,1) + psevp(i,k) = min(max(psevp(i,k),-qs(i,k)/dtcld),0.) + endif +!------------------------------------------------------------- +! pgevp: evaporation of melting graupel [HL A25] [RH84 A19] +! (T>=T0: G->V) +!------------------------------------------------------------- + if(qg(i,k).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & + + precg2*work2(i,k)*coeres)/work1(i,k,1) + pgevp(i,k) = min(max(pgevp(i,k),-qg(i,k)/dtcld),0.) + endif + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite +! + delta2=0. + delta3=0. + if(qr(i,k).lt.1.e-4.and.qs(i,k).lt.1.e-4) delta2=1. + if(qr(i,k).lt.1.e-4) delta3=1. + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qmin,qc(i,k)) + source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + endif +! +! cloud ice +! + value = max(qmin,qi(i,k)) + source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & + + pgaci(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psaut(i,k) = psaut(i,k)*factor + pigen(i,k) = pigen(i,k)*factor + pidep(i,k) = pidep(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + endif +! +! rain +! + value = max(qmin,qr(i,k)) + source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & + + pgacr(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + endif +! +! snow +! + value = max(qmin,qs(i,k)) + source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & + * delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & + + psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld + if (source.gt.value) then + factor = value/source + psdep(i,k) = psdep(i,k)*factor + psaut(i,k) = psaut(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! +! graupel +! + value = max(qmin,qg(i,k)) + source = -(pgdep(i,k)+pgaut(i,k) & + + piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & + + psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & + + pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgdep(i,k) = pgdep(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)-piacr(i,k)-pgacr(i,k) & + - psacr(i,k))*dtcld,0.) + qi(i,k) = max(qi(i,k)-(psaut(i,k)+praci(i,k) & + + psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & + * dtcld,0.) + qs(i,k) = max(qs(i,k)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & + - pgaut(i,k)+piacr(i,k)*delta3 & + + praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & + - pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & + * dtcld,0.) + qg(i,k) = max(qg(i,k)+(pgdep(i,k)+pgaut(i,k) & + + piacr(i,k)*(1.-delta3) & + + praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & + + pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & + + pgacr(i,k)+pgacs(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & + -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & + +paacw(i,k)+pgacr(i,k)+psacr(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + else +! +! cloud water +! + value = max(qmin,qc(i,k)) + source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + endif +! +! rain +! + value = max(qmin,qr(i,k)) + source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & + -paacw(i,k)-prevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif +! +! snow +! + value = max(qcrmin,qs(i,k)) + source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + psevp(i,k) = psevp(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + endif +! +! graupel +! + value = max(qcrmin,qg(i,k)) + source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + pgevp(i,k) = pgevp(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & + - pgeml(i,k))*dtcld,0.) + qs(i,k) = max(qs(i,k)+(psevp(i,k)-pgacs(i,k) & + + pseml(i,k))*dtcld,0.) + qg(i,k) = max(qg(i,k)+(pgacs(i,k)+pgevp(i,k) & + + pgeml(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & + -xlf*(pseml(i,k)+pgeml(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + endif + enddo + enddo +! +! Inline expansion for fpvs +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = conden(t(i,k),q(i,k),qsat(i,k,1),xl(i,k),cpm(i,k)) + work2(i,k) = qc(i,k)+work1(i,k,1) + pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qc(i,k).gt.0..and.work1(i,k,1).lt.0.) & + pcond(i,k) = max(work1(i,k,1),-qc(i,k))/dtcld + q(i,k) = q(i,k)-pcond(i,k)*dtcld + qc(i,k) = max(qc(i,k)+pcond(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qc(i,k).le.qmin) qc(i,k) = 0.0 + if(qi(i,k).le.qmin) qi(i,k) = 0.0 + enddo + enddo + enddo ! big loops + + if(present(rainprod2d) .and. present(evapprod2d)) then + do k = kts, kte + do i = its,ite + rainprod2d(i,k) = praut(i,k)+pracw(i,k)+praci(i,k)+psaci(i,k)+pgaci(i,k) & + + psacw(i,k)+pgacw(i,k)+paacw(i,k)+psaut(i,k) + evapprod2d(i,k) = -(prevp(i,k)+psevp(i,k)+pgevp(i,k)+psdep(i,k)+pgdep(i,k)) + enddo + enddo + endif +! +!---------------------------------------------------------------- +! CCPP checks: +! + + errmsg = 'mp_wsm6_run OK' + errflg = 0 + + end subroutine mp_wsm6_run + +!================================================================================================================= + real(kind=kind_phys) function rgmma(x) +!================================================================================================================= +!rgmma function: use infinite product form + + real(kind=kind_phys),intent(in):: x + + integer:: i + real(kind=kind_phys),parameter:: euler=0.577215664901532 + real(kind=kind_phys):: y + +!----------------------------------------------------------------------------------------------------------------- + + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i = 1,10000 + y = float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + + end function rgmma + +!================================================================================================================= + real(kind=kind_phys) function fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!================================================================================================================= + + integer,intent(in):: ice + real(kind=kind_phys),intent(in):: cice,cliq,cvap,hsub,hvap,psat,rd,rv,t0c + real(kind=kind_phys),intent(in):: t + + real(kind=kind_phys):: tr,ttp,dldt,dldti,xa,xb,xai,xbi + +!----------------------------------------------------------------------------------------------------------------- + + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif + + end function fpvs + +!================================================================================================================= + subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: den,denfac,t + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte,3):: qrs + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,3):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,lamdas,lamdag,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 + + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin)then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 + enddo + enddo + + end subroutine slope_wsm6 + +!================================================================================================================= + subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_rain + +!================================================================================================================= + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdas,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_snow + +!================================================================================================================= + subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdag,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 + + do k = kts, kte + do i = its, ite +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopegmax + rslopeb(i,k) = rslopegbmax + rslope2(i,k) = rslopeg2max + rslope3(i,k) = rslopeg3max + else + rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtg + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_graup + +!================================================================================================================= + subroutine nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!================================================================================================================= +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,wwl + +!---- local variables and arrays: + integer:: i,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,wd,wa,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qmi,qpi + +!----------------------------------------------------------------------------------------------------------------- + + precip(:) = 0.0 + + i_loop: do i=1,im + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) + enddo i_loop + + end subroutine nislfv_rain_plm + +!================================================================================================================= + subroutine nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2,precip1,precip2,dt,id,iter) +!================================================================================================================= +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip1,precip2 + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,rql2,wwl + +!---- local variables and arrays: + integer:: i,ist,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,qq2,wd,wa,wa2,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,qr2,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qa2,qmi,qpi + real(kind=kind_phys),dimension(im):: precip + +!----------------------------------------------------------------------------------------------------------------- + + precip(:) = 0.0 + precip1(:) = 0.0 + precip2(:) = 0.0 + + i_loop: do i=1,im + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + qq2(:) = rql2(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + qq2(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qa2(k) = qq2(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + qr2(k) = qa2(k)/den(k) + enddo + qa(km+1) = 0.0 + qa2(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) + do k = 1, km + tmp(k) = max((qr(k)+qr2(k)), 1.E-15) + if( tmp(k) .gt. 1.e-15 ) then + wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) + else + wa(k) = 0. + endif + enddo + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & +! ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif + + ist_loop : do ist = 1, 2 + if (ist.eq.2) then + qa(:) = qa2(:) + endif +! + precip(i) = 0. +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + if(ist.eq.1) then + rql(i,:) = qn(:) + precip1(i) = precip(i) + else + rql2(i,:) = qn(:) + precip2(i) = precip(i) + endif + enddo ist_loop + + enddo i_loop + + end subroutine nislfv_rain_plm6 + +!================================================================================================================= + subroutine refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ,kts,kte) + implicit none +!================================================================================================================= + +!..Sub arguments + integer,intent(in):: kts,kte + real(kind=kind_phys),intent(in),dimension(kts:kte):: qv1d,qr1d,qs1d,qg1d,t1d,p1d + real(kind=kind_phys),intent(inout),dimension(kts:kte):: dBz + +!..Local variables + logical:: melti + logical,dimension(kts:kte):: l_qr,l_qs,l_qg + + INTEGER:: i,k,k_0,kbot,n + + real(kind=kind_phys),parameter:: R=287. + real(kind=kind_phys):: temp_c + real(kind=kind_phys),dimension(kts:kte):: temp,pres,qv,rho + real(kind=kind_phys),dimension(kts:kte):: rr,rs,rg + real(kind=kind_phys),dimension(kts:kte):: ze_rain,ze_snow,ze_graupel + + double precision:: fmelt_s,fmelt_g + double precision:: cback,x,eta,f_d + double precision,dimension(kts:kte):: ilamr,ilams,ilamg + double precision,dimension(kts:kte):: n0_r, n0_s, n0_g + double precision:: lamr,lams,lamg + +!----------------------------------------------------------------------------------------------------------------- + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + temp_c = min(-0.001, temp(k)-273.15) + qv(k) = max(1.e-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + + if (qr1d(k) .gt. 1.e-9) then + rr(k) = qr1d(k)*rho(k) + n0_r(k) = n0r + lamr = (xam_r*xcrg(3)*n0_r(k)/rr(k))**(1./xcre(1)) + ilamr(k) = 1./lamr + l_qr(k) = .true. + else + rr(k) = 1.e-12 + l_qr(k) = .false. + endif + + if (qs1d(k) .gt. 1.e-9) then + rs(k) = qs1d(k)*rho(k) + n0_s(k) = min(n0smax, n0s*exp(-alpha*temp_c)) + lams = (xam_s*xcsg(3)*n0_s(k)/rs(k))**(1./xcse(1)) + ilams(k) = 1./lams + l_qs(k) = .true. + else + rs(k) = 1.e-12 + l_qs(k) = .false. + endif + + if (qg1d(k) .gt. 1.e-9) then + rg(k) = qg1d(k)*rho(k) + n0_g(k) = n0g + lamg = (xam_g*xcgg(3)*n0_g(k)/rg(k))**(1./xcge(1)) + ilamg(k) = 1./lamg + l_qg(k) = .true. + else + rg(k) = 1.e-12 + l_qg(k) = .false. + endif + enddo + +!+---+-----------------------------------------------------------------+ +!..Locate K-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + melti = .false. + k_0 = kts + do k = kte-1, kts, -1 + if ( (temp(k).gt.273.15) .and. L_qr(k) & + .and. (L_qs(k+1).or.L_qg(k+1)) ) then + k_0 = MAX(k+1, k_0) + melti=.true. + goto 195 + endif + enddo + 195 continue + +!+---+-----------------------------------------------------------------+ +!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. Integrations of m(D)*m(D)*N(D)*dD. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + ze_graupel(k) = 1.e-22 + if (l_qr(k)) ze_rain(k) = n0_r(k)*xcrg(4)*ilamr(k)**xcre(4) + if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & + * (xam_s/900.0)*(xam_s/900.0) & + * n0_s(k)*xcsg(4)*ilams(k)**xcse(4) + if (l_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & + * (xam_g/900.0)*(xam_g/900.0) & + * n0_g(k)*xcgg(4)*ilamg(k)**xcge(4) + enddo + + +!+---+-----------------------------------------------------------------+ +!..Special case of melting ice (snow/graupel) particles. Assume the +!.. ice is surrounded by the liquid water. Fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + + if (melti .and. k_0.ge.kts+1) then + do k = k_0-1, kts, -1 + +!..Reflectivity contributed by melting snow + if (L_qs(k) .and. L_qs(k_0) ) then + fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) + eta = 0.d0 + lams = 1./ilams(k) + do n = 1, nrbins + x = xam_s * xxDs(n)**xbm_s + call rayleigh_soak_wetgraupel (x,dble(xocms),dble(xobms), & + fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + cback, mixingrulestring_s, matrixstring_s, & + inclusionstring_s, hoststring_s, & + hostmatrixstring_s, hostinclusionstring_s) + f_d = n0_s(k)*xxds(n)**xmu_s * dexp(-lams*xxds(n)) + eta = eta + f_d * cback * simpson(n) * xdts(n) + enddo + ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta) + endif + + +!..Reflectivity contributed by melting graupel + + if (l_qg(k) .and. l_qg(k_0) ) then + fmelt_g = max(0.005d0, min(1.0d0-rg(k)/rg(k_0), 0.99d0)) + eta = 0.d0 + lamg = 1./ilamg(k) + do n = 1, nrbins + x = xam_g * xxdg(n)**xbm_g + call rayleigh_soak_wetgraupel (x,dble(xocmg),dble(xobmg), & + fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & + cback, mixingrulestring_g, matrixstring_g, & + inclusionstring_g, hoststring_g, & + hostmatrixstring_g, hostinclusionstring_g) + f_d = n0_g(k)*xxdg(n)**xmu_g * dexp(-lamg*xxdg(n)) + eta = eta + f_d * cback * simpson(n) * xdtg(n) + enddo + ze_graupel(k) = sngl(lamda4 / (pi5 * k_w) * eta) + endif + + enddo + endif + + do k = kte, kts, -1 + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + enddo + + + end subroutine refl10cm_wsm6 + + +!================================================================================================================= + end module mp_wsm6 +!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6_effectRad.F90 b/phys/physics_mmm/mp_wsm6_effectRad.F90 new file mode 100644 index 0000000000..0041adfadc --- /dev/null +++ b/phys/physics_mmm/mp_wsm6_effectRad.F90 @@ -0,0 +1,188 @@ +!================================================================================================================= + module mp_wsm6_effectrad + use ccpp_kind_types,only: kind_phys + + + use mp_wsm6,only: alpha,n0s,n0smax,pidn0s,pidnc + + + implicit none + private + public:: mp_wsm6_effectRad_run, & + mp_wsm6_effectrad_init, & + mp_wsm6_effectRad_finalize + + + contains + + +!================================================================================================================= + subroutine mp_wsm6_effectRad_init(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_init OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_init + +!================================================================================================================= + subroutine mp_wsm6_effectRad_finalize(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_final OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_finalize + +!================================================================================================================= + subroutine mp_wsm6_effectRad_run(do_microp_re,t,qc,qi,qs,rho,qmin,t0c,re_qc_bg,re_qi_bg,re_qs_bg, & + re_qc_max,re_qi_max,re_qs_max,re_qc,re_qi,re_qs,its,ite,kts,kte, & + errmsg,errflg) +!================================================================================================================= +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------------------------------------------------- + + +!..Sub arguments + logical,intent(in):: do_microp_re + integer,intent(in):: its,ite,kts,kte + real(kind=kind_phys),intent(in):: qmin + real(kind=kind_phys),intent(in):: t0c + real(kind=kind_phys),intent(in):: re_qc_bg,re_qi_bg,re_qs_bg + real(kind=kind_phys),intent(in):: re_qc_max,re_qi_max,re_qs_max + real(kind=kind_phys),dimension(its:,:),intent(in):: t + real(kind=kind_phys),dimension(its:,:),intent(in):: qc + real(kind=kind_phys),dimension(its:,:),intent(in):: qi + real(kind=kind_phys),dimension(its:,:),intent(in):: qs + real(kind=kind_phys),dimension(its:,:),intent(in):: rho + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qc + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qi + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qs + +!...Output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!..Local variables + integer:: i,k + integer:: inu_c + real(kind=kind_phys),dimension(its:ite,kts:kte):: ni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqc + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqi + real(kind=kind_phys),dimension(its:ite,kts:kte):: rni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqs + real(kind=kind_phys):: temp + real(kind=kind_phys):: lamdac + real(kind=kind_phys):: supcol,n0sfac,lamdas + real(kind=kind_phys):: diai ! diameter of ice in m + logical:: has_qc, has_qi, has_qs +!..Minimum microphys values + real(kind=kind_phys),parameter:: R1 = 1.E-12 + real(kind=kind_phys),parameter:: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real(kind=kind_phys),parameter:: bm_r = 3.0 + real(kind=kind_phys),parameter:: obmr = 1.0/bm_r + real(kind=kind_phys),parameter:: nc0 = 3.E8 + +!----------------------------------------------------------------------------------------------------------------- + + if(.not. do_microp_re) return + +!--- initialization of effective radii of cloud water, cloud ice, and snow to background values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = re_qc_bg + re_qi(i,k) = re_qi_bg + re_qs(i,k) = re_qs_bg + enddo + enddo + +!--- computation of effective radii: + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts,kte + do i = its,ite + ! for cloud + rqc(i,k) = max(R1,qc(i,k)*rho(i,k)) + if (rqc(i,k).gt.R1) has_qc = .true. + ! for ice + rqi(i,k) = max(R1,qi(i,k)*rho(i,k)) + temp = (rho(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(i,k)= max(R2,ni(i,k)*rho(i,k)) + if (rqi(i,k).gt.R1 .and. rni(i,k).gt.R2) has_qi = .true. + ! for snow + rqs(i,k) = max(R1,qs(i,k)*rho(i,k)) + if (rqs(i,k).gt.R1) has_qs = .true. + enddo + enddo + + if (has_qc) then + do k = kts,kte + do i = its,ite + if (rqc(i,k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(i,k))**obmr + re_qc(i,k) = max(2.51E-6,min(1.5*(1.0/lamdac),re_qc_max)) + enddo + enddo + endif + + if (has_qi) then + do k = kts,kte + do i = its,ite + if (rqi(i,k).le.R1 .or. rni(i,k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(i,k)/ni(i,k)) + re_qi(i,k) = max(10.01E-6,min(0.75*0.163*diai,re_qi_max)) + enddo + enddo + endif + + if (has_qs) then + do i = its,ite + do k = kts,kte + if (rqs(i,k).le.R1) CYCLE + supcol = t0c-t(i,k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(i,k))) + re_qs(i,k) = max(25.E-6,min(0.5*(1./lamdas),re_qs_max)) + enddo + enddo + endif + +!--- limit effective radii of cloud water, cloud ice, and snow to maximum values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = max(re_qc_bg,min(re_qc(i,k),re_qc_max)) + re_qi(i,k) = max(re_qi_bg,min(re_qi(i,k),re_qi_max)) + re_qs(i,k) = max(re_qs_bg,min(re_qs(i,k),re_qs_max)) + enddo + enddo + + errmsg = 'mp_wsm6_effectRad_run OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_run + +!================================================================================================================= + end module mp_wsm6_effectrad +!================================================================================================================= diff --git a/phys/physics_mmm/sf_sfclayrev.F90 b/phys/physics_mmm/sf_sfclayrev.F90 new file mode 100644 index 0000000000..d05ff3e45a --- /dev/null +++ b/phys/physics_mmm/sf_sfclayrev.F90 @@ -0,0 +1,1119 @@ +!================================================================================================================= + module sf_sfclayrev + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: sf_sfclayrev_run, & + sf_sfclayrev_init, & + sf_sfclayrev_finalize + + + real(kind=kind_phys),parameter:: vconvc= 1. + real(kind=kind_phys),parameter:: czo = 0.0185 + real(kind=kind_phys),parameter:: ozo = 1.59e-5 + + real(kind=kind_phys),dimension(0:1000 ),save:: psim_stab,psim_unstab,psih_stab,psih_unstab + + + contains + + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_init +!!\html\include sf_sfclayrev_init.html +!! + subroutine sf_sfclayrev_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables: + integer:: n + real(kind=kind_phys):: zolf + +!----------------------------------------------------------------------------------------------------------------- + + do n = 0,1000 +! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + +! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + + errmsg = 'sf_sfclayrev_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_init + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_finalize +!!\html\include sf_sfclayrev_finalize.html +!! + subroutine sf_sfclayrev_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'sf_sfclayrev_finalize OK' + errflg = 0 + + end subroutine sf_sfclayrev_finalize + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_run +!!\html\include sf_sfclayrev_run.html +!! + subroutine sf_sfclayrev_run(ux,vx,t1d,qv1d,p1d,dz8w1d, & + cp,g,rovcp,r,xlv,psfcpa,chs,chs2,cqs2, & + cpm,pblh,rmol,znt,ust,mavail,zol,mol, & + regime,psim,psih,fm,fh, & + xland,hfx,qfx,tsk, & + u10,v10,th2,t2,q2,flhc,flqc,qgh, & + qsfc,lh,gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,p1000mb,lakemask, & + shalwater_z0,water_depth, & + isftcflx,iz0tlnd,scm_force_flux, & + ustm,ck,cka,cd,cda, & + its,ite,errmsg,errflg & + ) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: isfflx + logical,intent(in):: shalwater_z0 + logical,intent(in),optional:: scm_force_flux + + integer,intent(in):: its,ite + integer,intent(in),optional:: isftcflx, iz0tlnd + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=kind_phys),intent(in):: ep1,ep2,karman + real(kind=kind_phys),intent(in):: p1000mb + real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv + + real(kind=kind_phys),intent(in),dimension(its:):: & + mavail, & + pblh, & + psfcpa, & + tsk, & + xland, & + lakemask, & + water_depth + + real(kind=kind_phys),intent(in),dimension(its:):: & + dx, & + dz8w1d, & + ux, & + vx, & + qv1d, & + p1d, & + t1d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(its:),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:):: & + regime, & + hfx, & + qfx, & + qsfc, & + mol, & + rmol, & + gz1oz0, & + wspd, & + br, & + psim, & + psih, & + fm, & + fh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + flhc, & + flqc, & + qgh + + real(kind=kind_phys),intent(inout),dimension(its:),optional:: & + ustm + +!--- local variables: + integer:: n,i,k,kk,l,nzol,nk,nzol2,nzol10 + + real(kind=kind_phys),parameter:: xka = 2.4e-5 + real(kind=kind_phys),parameter:: prt = 1. + real(kind=kind_phys),parameter:: salinity_factor = 0.98 + + real(kind=kind_phys):: pl,thcon,tvcon,e1 + real(kind=kind_phys):: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 + real(kind=kind_phys):: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 + real(kind=kind_phys):: fluxc,vsgd,z0q,visc,restar,czil,gz0ozq,gz0ozt + real(kind=kind_phys):: zw,zn1,zn2 + real(kind=kind_phys):: zolzz,zol0 + real(kind=kind_phys):: zl2,zl10,z0t + + real(kind=kind_phys),dimension(its:ite):: & + za, & + thvx, & + zqkl, & + zqklp1, & + thx, & + qx, & + psih2, & + psim2, & + psih10, & + psim10, & + denomq, & + denomq2, & + denomt2, & + wspdi, & + gz2oz0, & + gz10oz0, & + rhox, & + govrth, & + tgdsa, & + scr3, & + scr4, & + thgb, & + psfc + + real(kind=kind_phys),dimension(its:ite):: & + pq, & + pq2, & + pq10 + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite +!PSFC cb + psfc(i)=psfcpa(i)/1000. + enddo +! +!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: +! + do 5 i = its,ite + tgdsa(i)=tsk(i) +!PSFC cb +! thgb(i)=tsk(i)*(100./psfc(i))**rovcp + thgb(i)=tsk(i)*(p1000mb/psfcpa(i))**rovcp + 5 continue +! +!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., +! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. +! +! *** NOTE *** +! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, +! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE +! TENDENCIES. +! + 10 continue + +!do 24 i = its,ite +! ux(i)=u1d(i) +! vx(i)=v1d(i) +!24 continue + + 26 continue + +!.....SCR3(I,K) STORE TEMPERATURE, +! SCR4(I,K) STORE VIRTUAL TEMPERATURE. + + do 30 i = its,ite +!PL cb + pl=p1d(i)/1000. + scr3(i)=t1d(i) +! thcon=(100./pl)**rovcp + thcon=(p1000mb*0.001/pl)**rovcp + thx(i)=scr3(i)*thcon + scr4(i)=scr3(i) + thvx(i)=thx(i) + qx(i)=0. + 30 continue +! + do i = its,ite + qgh(i)=0. + flhc(i)=0. + flqc(i)=0. + cpm(i)=cp + enddo +! +!if(idry.eq.1)goto 80 + do 50 i = its,ite + qx(i)=qv1d(i) + tvcon=(1.+ep1*qx(i)) + thvx(i)=thx(i)*tvcon + scr4(i)=scr3(i)*tvcon + 50 continue +! + do 60 i=its,ite + e1=svp1*exp(svp2*(tgdsa(i)-svpt0)/(tgdsa(i)-svp3)) + !the saturation vapor pressure for salty water is on average 2% lower + if(xland(i).gt.1.5 .and. lakemask(i).eq.0.) e1=e1*salinity_factor + !for land points qsfc can come from previous time step + if(xland(i).gt.1.5.or.qsfc(i).le.0.0)qsfc(i)=ep2*e1/(psfc(i)-e1) +!QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE +!Q2SAT = QGH IN LSM + e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) + pl=p1d(i)/1000. + qgh(i)=ep2*e1/(pl-e1) + cpm(i)=cp*(1.+0.8*qx(i)) + 60 continue + 80 continue + +!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND +! LEVEL, AND THE LAYER THICKNESSES. + + do 90 i = its,ite + zqklp1(i)=0. + rhox(i)=psfc(i)*1000./(r*scr4(i)) + 90 continue +! + do 110 i = its,ite + zqkl(i)=dz8w1d(i)+zqklp1(i) + 110 continue +! + do 120 i = its,ite + za(i)=0.5*(zqkl(i)+zqklp1(i)) + 120 continue +! + do 160 i=its,ite + govrth(i)=g/thx(i) + 160 continue + +!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO +! AKB(1976), EQ(12). + do 260 i = its,ite + gz1oz0(i)=alog((za(i)+znt(i))/znt(i)) ! log((z+z0)/z0) + gz2oz0(i)=alog((2.+znt(i))/znt(i)) ! log((2+z0)/z0) + gz10oz0(i)=alog((10.+znt(i))/znt(i)) ! log((10+z0)z0) + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif + wspd(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + + tskv=thgb(i)*(1.+ep1*qsfc(i)) + dthvdz=(thvx(i)-tskv) +!-----CONVECTIVE VELOCITY SCALE VC AND SUBGRID-SCALE VELOCITY VSG +! FOLLOWING BELJAARS (1994, QJRMS) AND MAHRT AND SUN (1995, MWR) +! ... HONG AUG. 2001 +! +! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) +! USE BELJAARS OVER LAND, OLD MM5 (WYNGAARD) FORMULA OVER WATER + if(xland(i).lt.1.5) then + fluxc = max(hfx(i)/rhox(i)/cp & + + ep1*tskv*qfx(i)/rhox(i),0.) + vconv = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 + else + if(-dthvdz.ge.0)then + dthvm=-dthvdz + else + dthvm=0. + endif +! vconv = 2.*sqrt(dthvm) +! V3.7: REDUCING CONTRIBUTION IN CALM CONDITIONS + vconv = sqrt(dthvm) + endif +! MAHRT AND SUN LOW-RES CORRECTION + vsgd = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 + wspd(i)=sqrt(wspd(i)*wspd(i)+vconv*vconv+vsgd*vsgd) + wspd(i)=amax1(wspd(i),0.1) + br(i)=govrth(i)*za(i)*dthvdz/(wspd(i)*wspd(i)) +!-----IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 + if(mol(i).lt.0.)br(i)=amin1(br(i),0.0) + rmol(i)=-govrth(i)*dthvdz*za(i)*karman + 260 continue + +! +!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: +! +! +! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) +! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). +! +! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: +! +! 1. BR .GE. 0.0; +! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), +! +! 3. BR .EQ. 0.0 +! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), +! +! 4. BR .LT. 0.0 +! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). +! + + do 320 i = its,ite +! + if(br(i).gt.0) then + if(br(i).gt.250.0) then + zol(i)=zolri(250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif +! + if(br(i).lt.0) then + if(ust(i).lt.0.001)then + zol(i)=br(i)*gz1oz0(i) + else + if(br(i).lt.-250.0) then + zol(i)=zolri(-250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif + endif +! +! ... paj: compute integrated similarity functions. +! + zolzz=zol(i)*(za(i)+znt(i))/za(i) ! (z+z0/L + zol10=zol(i)*(10.+znt(i))/za(i) ! (10+z0)/L + zol2=zol(i)*(2.+znt(i))/za(i) ! (2+z0)/L + zol0=zol(i)*znt(i)/za(i) ! z0/L + zl2=(2.)/za(i)*zol(i) ! 2/L + zl10=(10.)/za(i)*zol(i) ! 10/L + + if((xland(i)-1.5).lt.0.)then + zl=(0.01)/za(i)*zol(i) ! (0.01)/L + else + zl=zol0 ! z0/L + endif + + if(br(i).lt.0.)goto 310 ! go to unstable regime (class 4) + if(br(i).eq.0.)goto 280 ! go to neutral regime (class 3) +! +!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: +! + regime(i)=1. +! +! ... paj: psim and psih. follows cheng and brutsaert 2005 (cb05). +! + psim(i)=psim_stable(zolzz)-psim_stable(zol0) + psih(i)=psih_stable(zolzz)-psih_stable(zol0) +! + psim10(i)=psim_stable(zol10)-psim_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) +! + psim2(i)=psim_stable(zol2)-psim_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) +! +! ... paj: preparations to compute psiq. follows cb05+carlson boland jam 1978. +! + pq(i)=psih_stable(zol(i))-psih_stable(zl) + pq2(i)=psih_stable(zl2)-psih_stable(zl) + pq10(i)=psih_stable(zl10)-psih_stable(zl) +! +! 1.0 over monin-obukhov length + rmol(i)=zol(i)/za(i) +! + goto 320 +! +!-----CLASS 3; FORCED CONVECTION: +! + 280 regime(i)=3. + psim(i)=0.0 + psih(i)=psim(i) + psim10(i)=0. + psih10(i)=psim10(i) + psim2(i)=0. + psih2(i)=psim2(i) +! +! paj: preparations to compute PSIQ. +! + pq(i)=psih(i) + pq2(i)=psih2(i) + pq10(i)=0. +! + zol(i)=0. + rmol(i) = zol(i)/za(i) + + goto 320 +! +!-----CLASS 4; FREE CONVECTION: +! + 310 continue + regime(i)=4. +! +! ... paj: PSIM and PSIH ... +! + psim(i)=psim_unstable(zolzz)-psim_unstable(zol0) + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) +! + psim10(i)=psim_unstable(zol10)-psim_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) +! + psim2(i)=psim_unstable(zol2)-psim_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) +! +! ... paj: preparations to compute PSIQ +! + pq(i)=psih_unstable(zol(i))-psih_unstable(zl) + pq2(i)=psih_unstable(zl2)-psih_unstable(zl) + pq10(i)=psih_unstable(zl10)-psih_unstable(zl) +! +!-----LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS +!-----THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL + psih(i)=amin1(psih(i),0.9*gz1oz0(i)) + psim(i)=amin1(psim(i),0.9*gz1oz0(i)) + psih2(i)=amin1(psih2(i),0.9*gz2oz0(i)) + psim10(i)=amin1(psim10(i),0.9*gz10oz0(i)) +! +! AHW: mods to compute ck, cd + psih10(i)=amin1(psih10(i),0.9*gz10oz0(i)) + rmol(i) = zol(i)/za(i) + + 320 continue +! +!-----COMPUTE THE FRICTIONAL VELOCITY: +! ZA(1982) EQS(2.60),(2.61). +! + do 330 i = its,ite + dtg=thx(i)-thgb(i) + psix=gz1oz0(i)-psim(i) + psix10=gz10oz0(i)-psim10(i) + +! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL +! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 +! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) + psit=gz1oz0(i)-psih(i) + psit2=gz2oz0(i)-psih2(i) +! + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +! + psiq=alog(karman*ust(i)*za(i)/xka+za(i)/zl)-pq(i) + psiq2=alog(karman*ust(i)*2./xka+2./zl)-pq2(i) + +! AHW: mods to compute ck, cd + psiq10=alog(karman*ust(i)*10./xka+10./zl)-pq10(i) + +! v3.7: using fairall 2003 to compute z0q and z0t over water: +! adapted from module_sf_mynn.f + if((xland(i)-1.5).ge.0.) then + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 + restar=ust(i)*znt(i)/visc + z0t = (5.5e-5)*(restar**(-0.60)) + z0t = min(z0t,1.0e-4) + z0t = max(z0t,2.0e-9) + z0q = z0t + +! following paj: + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) + + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + endif + + if(present(isftcflx)) then + if(isftcflx.eq.1 .and. (xland(i)-1.5).ge.0.) then +! v3.1 +! z0q = 1.e-4 + 1.e-3*(max(0.,ust(i)-1.))**2 +! hfip1 +! z0q = 0.62*2.0e-5/ust(i) + 1.e-3*(max(0.,ust(i)-1.5))**2 +! v3.2 + z0q = 1.e-4 +! +! ... paj: recompute psih for z0q +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psit=psiq + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + psit2=psiq2 + endif + if(isftcflx.eq.2 .and. (xland(i)-1.5).ge.0.) then +! AHW: Garratt formula: Calculate roughness Reynolds number +! Kinematic viscosity of air (linear approc to +! temp dependence at sea level) +! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which +! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 +! visc=1.5e-5 + restar=ust(i)*znt(i)/visc + gz0ozt=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.71)-5.) +! +! ... paj: compute psih for z0t for temperature ... +! + z0t=znt(i)/exp(gz0ozt) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! +! psit=gz1oz0(i)-psih(i)+restar2 +! psit2=gz2oz0(i)-psih2(i)+restar2 + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) +! + gz0ozq=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.60)-5.) + z0q=znt(i)/exp(gz0ozq) +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) +! psiq=gz1oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. +! psiq2=gz2oz0(i)-psih2(i)+2.28*sqrt(sqrt(restar))-2. +! psiq10=gz10oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. + endif + endif + if(present(ck) .and. present(cd) .and. present(cka) .and. present(cda)) then + ck(i)=(karman/psix10)*(karman/psiq10) + cd(i)=(karman/psix10)*(karman/psix10) + cka(i)=(karman/psix)*(karman/psiq) + cda(i)=(karman/psix)*(karman/psix) + endif + if(present(iz0tlnd)) then + if(iz0tlnd.ge.1 .and. (xland(i)-1.5).le.0.) then + zl=znt(i) +! CZIL RELATED CHANGES FOR LAND + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 + restar=ust(i)*zl/visc +! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 +! If iz0tlnd = 2, use traditional value + + if(iz0tlnd.eq.1) then + czil = 10.0 ** ( -0.40 * ( zl / 0.07 ) ) + elseif(iz0tlnd.eq.2) then + czil = 0.1 + endif +! +! ... paj: compute phish for z0t over land +! + z0t=znt(i)/exp(czil*karman*sqrt(restar)) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0t)/z0t)-psih(i) + psiq2=alog((2.+z0t)/z0t)-psih2(i) + psit=psiq + psit2=psiq2 +! +! psit=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psiq=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psit2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) +! psiq2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) + endif + endif +! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE + ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix +! TKE coupling: compute ust without vconv for use in tke scheme + wspdi(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + if(present(ustm)) then + ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix + endif + + u10(i)=ux(i)*psix10/psix + v10(i)=vx(i)*psix10/psix + th2(i)=thgb(i)+dtg*psit2/psit + q2(i)=qsfc(i)+(qx(i)-qsfc(i))*psiq2/psiq + t2(i) = th2(i)*(psfcpa(i)/p1000mb)**rovcp +! + if((xland(i)-1.5).lt.0.)then + ust(i)=amax1(ust(i),0.001) + endif + mol(i)=karman*dtg/psit/prt + denomq(i)=psiq + denomq2(i)=psiq2 + denomt2(i)=psit2 + fm(i)=psix + fh(i)=psit + 330 continue +! + 335 continue + +!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: + if(present(scm_force_flux) ) then + if(scm_force_flux) goto 350 + endif + do i = its,ite + qfx(i)=0. + hfx(i)=0. + enddo + 350 continue + + if(.not. isfflx) goto 410 + +!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). + do 360 i = its,ite + if((xland(i)-1.5).ge.0)then +! znt(i)=czo*ust(i)*ust(i)/g+ozo + ! PSH - formulation for depth-dependent roughness from + ! ... Jimenez and Dudhia, 2018 + if(shalwater_z0) then + znt(i) = depth_dependent_z0(water_depth(i),znt(i),ust(i)) + else + !Since V3.7 (ref: EC Physics document for Cy36r1) + znt(i)=czo*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) + ! v3.9: add limit as in isftcflx = 1,2 + znt(i)=min(znt(i),2.85e-3) + endif +! COARE 3.5 (Edson et al. 2013) +! czc = 0.0017*wspd(i)-0.005 +! czc = min(czc,0.028) +! znt(i)=czc*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) +! AHW: change roughness length, and hence the drag coefficients Ck and Cd + if(present(isftcflx)) then + if(isftcflx.ne.0) then +! znt(i)=10.*exp(-9.*ust(i)**(-.3333)) +! znt(i)=10.*exp(-9.5*ust(i)**(-.3333)) +! znt(i)=znt(i) + 0.11*1.5e-5/amax1(ust(i),0.01) +! znt(i)=0.011*ust(i)*ust(i)/g+ozo +! znt(i)=max(znt(i),3.50e-5) +! AHW 2012: + zw = min((ust(i)/1.06)**(0.3),1.0) + zn1 = 0.011*ust(i)*ust(i)/g + ozo + zn2 = 10.*exp(-9.5*ust(i)**(-.3333)) + & + 0.11*1.5e-5/amax1(ust(i),0.01) + znt(i)=(1.0-zw) * zn1 + zw * zn2 + znt(i)=min(znt(i),2.85e-3) + znt(i)=max(znt(i),1.27e-7) + endif + endif + zl = znt(i) + else + zl = 0.01 + endif + flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/denomq(i) +! flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/( & +! alog(karman*ust(i)*za(i)/xka+za(i)/zl)-psih(i)) + dtthx=abs(thx(i)-thgb(i)) + if(dtthx.gt.1.e-5)then + flhc(i)=cpm(i)*rhox(i)*ust(i)*mol(i)/(thx(i)-thgb(i)) +! write(*,1001)flhc(i),cpm(i),rhox(i),ust(i),mol(i),thx(i),thgb(i),i + 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) + else + flhc(i)=0. + endif + 360 continue + +! +!-----COMPUTE SURFACE MOIST FLUX: +! +!IF(IDRY.EQ.1)GOTO 390 +! + if(present(scm_force_flux)) then + if(scm_force_flux) goto 405 + endif + + do 370 i = its,ite + qfx(i)=flqc(i)*(qsfc(i)-qx(i)) +! qfx(i)=amax1(qfx(i),0.) + lh(i)=xlv*qfx(i) + 370 continue + +!-----COMPUTE SURFACE HEAT FLUX: +! + 390 continue + do 400 i = its,ite + if(xland(i)-1.5.gt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) +! if(present(isftcflx)) then +! if(isftcflx.ne.0) then +! AHW: add dissipative heating term (commented out in 3.6.1) +! hfx(i)=hfx(i)+rhox(i)*ustm(i)*ustm(i)*wspdi(i) +! endif +! endif + elseif(xland(i)-1.5.lt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) +! hfx(i)=amax1(hfx(i),-250.) + endif + 400 continue + + 405 continue + + do i = its,ite + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +!v3.1.1 +! chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & +! /xka+za(i)/zl)-psih(i)) + chs(i)=ust(i)*karman/denomq(i) +! gz2oz0(i)=alog(2./znt(i)) +! psim2(i)=-10.*gz2oz0(i) +! psim2(i)=amax1(psim2(i),-10.) +! psih2(i)=psim2(i) +! v3.1.1 +! cqs2(i)=ust(i)*karman/(alog(karman*ust(i)*2.0 & +! /xka+2.0/zl)-psih2(i)) +! chs2(i)=ust(i)*karman/(gz2oz0(i)-psih2(i)) + cqs2(i)=ust(i)*karman/denomq2(i) + chs2(i)=ust(i)*karman/denomt2(i) + enddo + + 410 continue + +!jdf +! do i = its,ite +! if(ust(i).ge.0.1) then +! rmol(i)=rmol(i)*(-flhc(i))/(ust(i)*ust(i)*ust(i)) +! else +! rmol(i)=rmol(i)*(-flhc(i))/(0.1*0.1*0.1) +! endif +! enddo +!jdf + + errmsg = 'sf_sfclayrev_run OK' + errflg = 0 + + end subroutine sf_sfclayrev_run + +!================================================================================================================= + real(kind=kind_phys) function zolri(ri,z,z0) + real(kind=kind_phys),intent(in):: ri,z,z0 + + integer:: iter + real(kind=kind_phys):: fx1,fx2,x1,x2 + + + if(ri.lt.0.)then + x1=-5. + x2=0. + else + x1=0. + x2=5. + endif + + fx1=zolri2(x1,ri,z,z0) + fx2=zolri2(x2,ri,z,z0) + iter = 0 + do while (abs(x1 - x2) > 0.01) + if (iter .eq. 10) return +!check added for potential divide by zero (2019/11) + if(fx1.eq.fx2)return + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,z,z0) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,z,z0) + zolri=x2 + endif + iter = iter + 1 + enddo + + return + end function zolri + +!================================================================================================================= + real(kind=kind_phys) function zolri2(zol2,ri2,z,z0) + real(kind=kind_phys),intent(in):: ri2,z,z0 + real(kind=kind_phys),intent(inout):: zol2 + real(kind=kind_phys):: psih2,psix2,zol20,zol3 + + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 + + zol20=zol2*z0/z ! z0/L + zol3=zol2+zol20 ! (z+z0)/L + + if(ri2.lt.0) then + psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) + else + psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) + endif + + zolri2=zol2*psih2/psix2**2-ri2 + + return + end function zolri2 + +!================================================================================================================= +! +! ... integrated similarity functions ... +! + real(kind=kind_phys) function psim_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + + return + end function psim_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + + return + end function psih_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psimc,psimk,x,y,ym + x=(1.-16.*zolf)**.25 + psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) + + ym=(1.-10.*zolf)**0.33 + psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + return + end function psim_unstable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psihc,psihk,y,yh + y=(1.-16.*zolf)**.5 + psihk=2.*log((1+y)/2.) + + yh=(1.-34.*zolf)**0.33 + psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) + + return + end function psih_unstable_full + +!================================================================================================================= +! ... look-up table functions ... + real(kind=kind_phys) function psim_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + psim_stable = psim_stable_full(zolf) + endif + + return + end function psim_stable + +!================================================================================================================= + real(kind=kind_phys) function psih_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + psih_stable = psih_stable_full(zolf) + endif + + return + end function psih_stable + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + psim_unstable = psim_unstable_full(zolf) + endif + + return + end function psim_unstable + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + psih_unstable = psih_unstable_full(zolf) + endif + + return + end function psih_unstable + +!================================================================================================================= + real(kind=kind_phys) function depth_dependent_z0(water_depth,z0,ust) + real(kind=kind_phys),intent(in):: water_depth,z0,ust + real(kind=kind_phys):: depth_b + real(kind=kind_phys):: effective_depth + if(water_depth .lt. 10.0) then + effective_depth = 10.0 + elseif(water_depth .gt. 100.0) then + effective_depth = 100.0 + else + effective_depth = water_depth + endif + + depth_b = 1 / 30.0 * log (1260.0 / effective_depth) + depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) + depth_dependent_z0 = MIN(depth_dependent_z0,0.1) + + return + end function depth_dependent_z0 + +!================================================================================================================= + end module sf_sfclayrev +!================================================================================================================= diff --git a/run/README.namelist b/run/README.namelist index e37c584d46..8985492b72 100644 --- a/run/README.namelist +++ b/run/README.namelist @@ -251,7 +251,8 @@ Namelist variables specifically for the WPS input for real: rh2qv_method = 1, ! which method to use to computer mixing ratio from RH: default is option 1, the old MM5 method; option 2 uses a WMO recommended method (WMO-No. 49, corrigendum, August 2000) - - there is a difference between the two methods though small + use_sh_qv = .false., ! whether to use specific humidity or mixing ratio data from input + recommended if input data has high vertical resolution interp_theta = .false. ! If set to .false., it will vertically interpolate temperature instead of potential temperature, which may reduce bias when compared with input data @@ -487,26 +488,15 @@ Namelist variables for controlling the adaptive time step option: = 13, SBU_YLIN scheme = 14, WDM 5-class scheme = 16, WDM 6-class scheme - = 17, NSSL 2-moment 4-ice scheme (steady background CCN) - = 18, NSSL 2-moment 4-ice scheme with predicted CCN (better for idealized than real cases) - to set a global CCN value, use - nssl_cccn = 0.7e9 ; CCN for NSSL scheme (18). - Also sets same value to ccn_conc for mp_physics=18 - = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) - = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 - Can set intercepts and particle densities in physics namelist, e.g., nssl_cnor + = 18, NSSL 2-moment 4-ice scheme with predicted (unactivated) CCN (or activated CCN) + to change global CCN value, use + nssl_cccn = 0.7e9 ; CCN (#/m^3 at sea level pressure) for NSSL scheme (18) or nssl_ccn_on=1 + Also sets ccn_conc for mp_physics=18 For NSSL 1-moment schemes, intercept and particle densities can be set for snow, graupel, hail, and rain. For the 1- and 2-moment schemes, the shape parameters for graupel and hail can be set. - nssl_alphah = 0. ! shape parameter for graupel - nssl_alphahl = 2. ! shape parameter for hail - nssl_cnoh = 4.e5 ! graupel intercept - nssl_cnohl = 4.e4 ! hail intercept - nssl_cnor = 8.e5 ! rain intercept - nssl_cnos = 3.e6 ! snow intercept - nssl_rho_qh = 500. ! graupel density - nssl_rho_qhl = 900. ! hail density - nssl_rho_qs = 100. ! snow density + PLEASE SEE README.NSSLmp for options affecting the NSSL scheme + = 17, 19, 21, 22: Legacy NSSL-MP options: see README.NSSLmp for equivalent settings with 18 = 24, WSM 7-class scheme (separate hail and graupel categories) = 26, WDM 7-class scheme (separate hail and graupel categories) = 28, aerosol-aware Thompson scheme with water- and ice-friendly aerosol climatology @@ -571,14 +561,14 @@ Namelist variables for controlling the adaptive time step option: acc_phy_tend = 0 ! set to =1 to output 16 accumulated physics tendencies for potential temp, water vaopr mixing ratio, and U/V wind components; default is 0=off (new in 4.4) progn (max_dom) = 0 ! switch to use mix-activate scheme (Only for Morrison, WDM6, WDM5, - and NSSL_2MOMCCN/NSSL_2MOM - ccn_conc = 1.E8 ! CCN concentration, used by WDM schemes + and NSSL_2MOM) + ccn_conc = 1.E8 ! CCN concentration, used by WDM schemes (set automatically for NSSL_2MOM using nssl_cccn) no_mp_heating = 0 ! normal = 1 ! turn off latent heating from a microphysics scheme use_mp_re = 1 ! whether to use effective radii computed in mp schemes in RRTMG 0: do not use; 1: use effective radii - (The mp schemes that compute effective radii are 3,4,6,7,8,10,14,16,17-21,24,26,28,50-53,55) + (The mp schemes that compute effective radii are 3,4,6,7,8,10,14,16,18,24,26,28,50-53,55) force_read_thompson = .false. ! whether to read tables for mp_physics = 8,28 write_thompson_tables = .true. ! whether to read or compute tables for mp_phyiscs = 8,28 @@ -1070,8 +1060,10 @@ Namelist variables for controlling the adaptive time step option: ua_phys = .false. ! Option to activate UA Noah changes: a different snow-cover physics in Noah, aimed particularly toward improving treatment of snow as it relates to the vegetation canopy. Also uses new columns added in VEGPARM.TBL - do_radar_ref = 0, ! 1 = allows radar reflectivity to be computed using mp-scheme-specific - parameters. Currently works for mp_physics = 2,4,6,7,8,10,14,16,24,26,28 + do_radar_ref = 0, ! 1 = allows radar reflectivity to be computed using mp-scheme-specific + parameters. Currently works for mp_physics = 2,4,6,7,8,10,14,16,24,26,28 + Note that reflectivity is always computed for mp_physics = 9,18, and is + also set =1 when nwp_diagnostics=1 hailcast_opt (max_dom) = 0, ! 1 = 1-D hail growth model which predicts 1st-5th rank-ordered hail diameters, mean hail diameter and standard deviation of hail diameter. (Adams-Selin and Ziegler, MWR Dec 2016.) haildt (max_dom) = 0., ! seconds between WRF-HAILCAST calls (s) @@ -1133,10 +1125,26 @@ Options for MAD-WRF - see doc/README.madwrf for usage information Options for wind turbine drag parameterization: - windfarm_opt (max_dom) = 0 ! 1 = Simulates the effects of wind turbines in the atmospheric evolution + windfarm_opt (max_dom) = 0 ! 1 = Simulates the effects of wind turbines in the atmospheric evolution, A\activates the wind farm parameterization by Fitch et al (2012) + ! 2 = Activate the new wind farm scheme (mav scheme) based on Ma et al. (2022). + This is similar to option 1, but it also considers subgrid-scale wind turbine wake effects windfarm_ij = 0 ! whether to use lat-lon or i-j coordinate as wind turbine locations ! 0 = The coordinate of the turbines are defined in terms of lat-lon ! 1 = The coordinate of the turbines are defined in terms of grid points + ! 2 = Valid only with windfarm_opt=2. The coordinate of the turbines are defined + in terms of lat-lon with the filename of 'windturbines-ll.txt' + windfarm_wake_model = 2 ! Subgrid-scale wind turbine wake model, valid only with windfarm_opt=2, default is 2 + ! 1 = The Jensen model + ! 2 = The XA model + ! 3 = The GM model (windfarm_method is not used) + ! 4 = Jensen and XA ensemble + ! 5 = Jensen, XA and GM ensemble + windfarm_overlap_method = 4 ! Wake superposition method for the Jensen and XA wind turbine wake model, valid only with windfarm_opt=2, default is 4 + ! 1 = linear superposition + ! 2 = squared superposition + ! 3 = modified squared superposition + ! 4 = superposition of the hub-height wind speed (Ma et al. 2022) + windfarm_deg = 0. ! The rotation degree of the wind farm layout. This is valid only when 'windfarm_opt=2' and 'windfarm_ij=1' windfarm_tke_factor = 0.25 ! Correction factor applied to the TKE coefficient (deafault is 0.25, Archer et al. 2020) diff --git a/run/URBPARM_LCZ.TBL b/run/URBPARM_LCZ.TBL index 80e6809c17..450d765f9d 100644 --- a/run/URBPARM_LCZ.TBL +++ b/run/URBPARM_LCZ.TBL @@ -32,21 +32,21 @@ SIGMA_ZED: 4.0, 3.0, 1.0, 1., 1., 1., 1., 1., 1., 1., 1. # ROOF_WIDTH: Roof (i.e., building) width [ m ] # (sf_urban_physics=1) -ROOF_WIDTH: 31.7, 25.7, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 10. +ROOF_WIDTH: 22.2, 22., 9.6, 42.86, 26.25, 13., 25., 28.9, 43.33, 23.8, 5. # # ROAD_WIDTH: road width [ m ] # (sf_urban_physics=1) # -ROAD_WIDTH: 98.9, 39.2, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0 +ROAD_WIDTH: 20., 14., 5.2, 50.0, 35.0, 13.0, 3.33, 32.5, 43.3, 28.6, 100.0 # # AH: Anthropogenic heat [ W m{-2} ] # (sf_urban_physics=1) # -AH: 100.0, 35.0, 30.0, 30.0, 15.0, 10.0, 30.0, 40.0, 5.0, 300.0, 0 +AH: 175.0, 37.5, 37.5, 25.0, 12.5, 12.5, 17.5, 25.0, 5.0, 350.0, 350.0 # @@ -54,7 +54,7 @@ AH: 100.0, 35.0, 30.0, 30.0, 15.0, 10.0, 30.0, 40.0, 5.0, 300.0, 0 # (sf_urban_physics=1) # -ALH: 20.0, 25.0, 40.0, 20.0, 25.0, 40.0, 20.0, 25.0, 40.0, 20.0, 0 +ALH: 20.0, 25.0, 40.0,20.0, 25.0, 40.0,20.0, 25.0, 40.0,20.0, 25.0 # # AKANDA_URBAN: Coefficient modifying the Kanda approach to computing @@ -232,90 +232,92 @@ DZGR: 0.05 0.10 0.15 0.20 # (sf_urban_physics=1,2,3) # -FRC_URB: 1.00, 0.99, 1.00, 0.65, 0.7, 0.65, 0.3, 0.85, 0.3, 0.55, 1.00 +FRC_URB: 0.95, 0.9,0.85, 0.65, 0.7, 0.6, 0.85, 0.85, 0.3, 0.55, 1.00 + # # CAPR: Heat capacity of roof [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPR: 1.8E6, 1.8E6, 1.44E6, 1.8E6, 1.8E6, 1.44E6, 2.0E6, 1.8E6, 1.44E6, 2.0E6, 1.8E6 +CAPR: 1.32E6,1.32E6,1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6 # # CAPB: Heat capacity of building wall [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPB: 1.8E6, 2.67E6, 2.05E6, 2.0E6, 2.0E6, 2.05E6, 0.72E6, 1.8E6, 2.56E6, 1.69E6, 1.8E6 +CAPB: 1.54E6,1.54E6,1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6 # # CAPG: Heat capacity of ground (road) [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPG: 1.75E6, 1.68E6, 1.63E6, 1.54E6, 1.50E6, 1.47E6, 1.67E6, 1.38E6, 1.37E6, 1.49E6, 1.38E6 +CAPG: 1.74E6,1.74E6,1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6 # # AKSR: Thermal conductivity of roof [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSR: 1.25, 1.25, 1.00, 1.25, 1.25, 1.00, 2.0, 1.25, 1.00, 2.00, 1.25 +AKSR: 1.54,1.54,1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54 # # AKSB: Thermal conductivity of building wall [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSB: 1.09, 1.5, 1.25, 1.45, 1.45, 1.25, 0.5, 1.25, 1.00, 1.33, 1.25 +AKSB: 1.51,1.51,1.51, 1.51, 1.51, 1.51,1.51,1.51,1.51, 1.51, 1.51 # # AKSG: Thermal conductivity of ground (road) [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSG: 0.77, 0.73, 0.69, 0.64, 0.62, 0.60, 0.72, 0.51, 0.55, 0.61, 0.51 +AKSG: 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82 # # ALBR: Surface albedo of roof [ fraction ] # (sf_urban_physics=1,2,3) # -ALBR: 0.13, 0.18, 0.15, 0.13, 0.13, 0.13, 0.15, 0.18, 0.13, 0.10, 0.13 +ALBR: 0.30, 0.30 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30 + # # ALBB: Surface albedo of building wall [ fraction ] # (sf_urban_physics=1,2,3) # -ALBB: 0.25, 0.20, 0.20, 0.25, 0.25, 0.25, 0.20, 0.25, 0.25, 0.20, 0.20 +ALBB: 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 # # ALBG: Surface albedo of ground (road) [ fraction ] # (sf_urban_physics=1,2,3) # -ALBG: 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.18, 0.14, 0.14, 0.14, 0.14 +ALBG: 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08 # # EPSR: Surface emissivity of roof [ - ] # (sf_urban_physics=1,2,3) # -EPSR: 0.91, 0.91, 0.91, 0.91, 0.91, 0.91, 0.28, 0.91, 0.91, 0.91, 0.95 +EPSR: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90 # # EPSB: Surface emissivity of building wall [-] # (sf_urban_physics=1,2,3) # -EPSB: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.95 +EPSB: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90 # # EPSG: Surface emissivity of ground (road) [ - ] # (sf_urban_physics=1,2,3) # -EPSG: 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.92, 0.95, 0.95, 0.95, 0.95 +EPSG: 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95 # # Z0B: Roughness length for momentum, over building wall [ m ] @@ -348,14 +350,14 @@ Z0R: 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 # (sf_urban_physics=1,2,3) # -TRLEND: 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00 +TRLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00 # # TBLEND: Lower boundary temperature for building wall temperature [ K ] # (sf_urban_physics=1,2,3) # -TBLEND: 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00 +TBLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00 # # TGLEND: Lower boundary temperature for ground (road) temperature [ K ] @@ -368,7 +370,7 @@ TGLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, # (sf_urban_physics=3) # -COP: 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5 +COP: 4., 4., 4., 4., 4., 4., 4., 4., 4., 4., 4. # # BLDAC_FRC: fraction of buildings installed with A/C systems [ - ] # (sf_urban_physics=3) @@ -388,7 +390,7 @@ COOLED_FRC: 1.0, 1.0, 1.0,1.0, 1.0, 1.0,1.0, 1.0, 1.0,1.0, 1.0 # (sf_urban_physics=3) # -PWIN: 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.9, 0.2, 0.2, 0.2, 0.0 +PWIN: 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.0 # # BETA: Thermal efficiency of heat exchanger @@ -450,7 +452,7 @@ GAPHUM: 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0. # (sf_urban_physics=3) # -PERFLO: 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.00 +PERFLO: 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.00 # @@ -465,7 +467,7 @@ HSEQUIP: 0.25 0.25 0.25 0.25 0.25 0.25 0.25 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 # (sf_urban_physics=3) # -HSEQUIP_SCALE_FACTOR: 36.00, 20.00, 20.00, 36.00, 20.00, 20.00, 20.00, 36.00, 20.00, 20.00, 20.00 +HSEQUIP_SCALE_FACTOR: 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00 # @@ -480,7 +482,7 @@ GR_FLAG:0 # (sf_urban_physics=3) # -GR_TYPE: 2 +GR_TYPE: 1 # # GR_FRAC_ROOF: fraction of green roof over the roof (0:1) @@ -502,8 +504,9 @@ IRHO:0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1 # (sf_urban_physics=3) # -PV_FRAC_ROOF: 0,0,0,0,0,0,0,0,0,0,0 +PV_FRAC_ROOF: 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0. +# STREET PARAMETERS: @@ -513,26 +516,26 @@ STREET PARAMETERS: # category direction width width # [index] [deg from N] [m] [m] - 1 0.0 15. 12. - 1 90.0 15. 12. - 2 0.0 10. 20. - 2 90.0 10. 20. - 3 0.0 5.7 9. - 3 90.0 5.7 9. - 4 0.0 30.0 20. - 4 90.0 30.0 20. - 5 0.0 20.0 20. - 5 90.0 20.0 20. - 6 0.0 12.4 10.5 - 6 90.0 12.4 10.5 - 7 0.0 10. 20. - 7 90.0 10. 20. - 8 0.0 32.5 28.8 - 8 90.0 32.5 28.8 - 9 0.0 10. 10. - 9 90.0 10. 10. - 10 0.0 28.5 23.8 - 10 90.0 28.5 23.8 + 1 0.0 20. 22.22 + 1 90.0 20. 22.22 + 2 0.0 14. 22. + 2 90.0 14. 22. + 3 0.0 5.2 9.6 + 3 90.0 5.2 9.6 + 4 0.0 50.0 42.86 + 4 90.0 50.0 42.86 + 5 0.0 35.0 26.25 + 5 90.0 35.0 26.25 + 6 0.0 13.0 13. + 6 90.0 13.0 13. + 7 0.0 3.33 25. + 7 90.0 3.33 25. + 8 0.0 32.5 28.9 + 8 90.0 32.5 28.9 + 9 0.0 43.3 43.33 + 9 90.0 43.3 43.33 + 10 0.0 28.6 23.8 + 10 90.0 28.6 23.8 11 0.0 100. 5. 11 90.0 100. 5. @@ -639,7 +642,6 @@ BUILDING HEIGHTS: 11 # height Percentage # [m] [%] - 5.0 100.0 + 5.0 100.0 END BUILDING HEIGHTS - diff --git a/share/module_check_a_mundo.F b/share/module_check_a_mundo.F index 4dbbb625a2..8ad4e88a6d 100644 --- a/share/module_check_a_mundo.F +++ b/share/module_check_a_mundo.F @@ -3374,6 +3374,98 @@ SUBROUTINE set_physics_rconfigs END IF +!----------------------------------------------------------------------- +! Check for deprecated options with NSSL-MP +!----------------------------------------------------------------------- + DO i = 1, model_config_rec % max_dom + IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE + IF ( model_config_rec % mp_physics(i) .EQ. 22 ) THEN + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 1 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_density_on = 1 ! set graupel density + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 22 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_hail_on=0, nssl_ccn_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 17 ) THEN + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 1 + model_config_rec % nssl_hail_on(i) = 1 + model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_density_on = 2 ! set graupel+hail density + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 17 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_ccn_on=0' + ! print statement for deprecated option + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 19 ) THEN + ! single-moment with hail + graupel density + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 2 + model_config_rec % nssl_density_on = 1 ! set graupel density + ! print statement for deprecated option + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 19 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 21 ) THEN + ! single-moment without + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_density_on = 0 ! set graupel density + ! print statement for deprecated option + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 21 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0, nssl_hail_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ENDIF + + IF ( model_config_rec % mp_physics(i) /= NSSL_2MOM ) THEN + ! If not NSSL-MP, make sure extra fields are turned off (in case of stray namelist settings) + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_density_on = 0 ! set graupel density + model_config_rec % nssl_3moment = 0 + model_config_rec % nssl_ccn_on = 0 + + ELSE ! make sure settings are consistent + + IF ( model_config_rec % nssl_ccn_on < 0 ) THEN + model_config_rec % nssl_ccn_on = 1 + ENDIF + + IF ( model_config_rec % nssl_2moment_on < 0 ) THEN ! turn on number concentrations + model_config_rec % nssl_2moment_on = 1 + ENDIF + + IF ( model_config_rec % nssl_hail_on(i) < 0 ) THEN + IF ( model_config_rec % nssl_2moment_on == 0 ) THEN + model_config_rec % nssl_hail_on(i) = 2 + ELSE + model_config_rec % nssl_hail_on(i) = 1 + ENDIF + ENDIF + + IF ( model_config_rec % nssl_density_on < 0 ) THEN + IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + model_config_rec % nssl_density_on = 2 ! set default of graupel+hail density + ELSE + model_config_rec % nssl_density_on = 1 ! set graupel density (hail off) + ENDIF + ENDIF + + IF ( model_config_rec % nssl_3moment == 1 ) THEN + model_config_rec % nssl_2moment_on = 1 + IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + model_config_rec % nssl_3moment = 2 ! 3mom rain, graupel and hail + ELSE + model_config_rec % nssl_3moment = 1 ! 3mom rain and graupel (no hail) + ENDIF + ENDIF + ENDIF + + ENDDO + !----------------------------------------------------------------------- ! If a user requested to compute the radar reflectivity .OR. if this is ! one of the schemes that ALWAYS computes the radar reflectivity, then @@ -3383,16 +3475,11 @@ SUBROUTINE set_physics_rconfigs DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( ( model_config_rec % mp_physics(i) .EQ. MILBRANDT2MOM ) .OR. & -#if (EM_CORE == 1) ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOM ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMG ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMCCN ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOM ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOMLFO ) .OR. & -#endif ( model_config_rec % do_radar_ref .EQ. 1 ) ) THEN model_config_rec % compute_radar_ref = 1 - END IF + ENDIF + ENDDO !----------------------------------------------------------------------- diff --git a/share/module_model_constants.F b/share/module_model_constants.F index ebb2425ddf..697d2f9486 100644 --- a/share/module_model_constants.F +++ b/share/module_model_constants.F @@ -62,6 +62,9 @@ MODULE module_model_constants REAL , PARAMETER :: RE_QC_BG = 2.49E-6 ! effective radius of cloud for background (m) REAL , PARAMETER :: RE_QI_BG = 4.99E-6 ! effective radius of ice for background (m) REAL , PARAMETER :: RE_QS_BG = 9.99E-6 ! effective radius of snow for background (m) + REAL , PARAMETER :: RE_QC_MAX = 50.E-6 ! max effective radius of cloud allowed + REAL , PARAMETER :: RE_QI_MAX = 125.E-6 ! max effective radius of ice allowed + REAL , PARAMETER :: RE_QS_MAX = 999.E-6 ! max effective radius of snow allowed ! ! Now namelist-specified parameter: ccn_conc - RAS ! REAL , PARAMETER :: n_ccn0 = 1.0E8 diff --git a/tools/reg_parse.c b/tools/reg_parse.c index 8e2e1a0fd1..3fe67fca9e 100644 --- a/tools/reg_parse.c +++ b/tools/reg_parse.c @@ -117,21 +117,30 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) for ( p = inln ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; if ( !strncmp( p , "include", 7 ) && ! ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) ) { FILE *include_fp ; + char include_file_name_local_registry[128] ; char include_file_name[128] ; p += 7 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; if ( strlen( p ) > 127 ) { fprintf(stderr,"Registry warning: invalid include file name: %s\n", p ) ; } else { - sprintf( include_file_name , "%s/%s", dir , p ) ; + + sprintf( include_file_name_local_registry, "./Registry/%s", p ) ; + sprintf( include_file_name, "%s/%s", dir , p ) ; + + if ( (p=index(include_file_name_local_registry,'\n')) != NULL ) *p = '\0' ; if ( (p=index(include_file_name,'\n')) != NULL ) *p = '\0' ; + fprintf(stderr,"opening %s\n",include_file_name) ; - if (( include_fp = fopen( include_file_name , "r" )) != NULL ) { + if ( ( ( include_fp = fopen( include_file_name_local_registry, "r" ) ) != NULL ) || // Use short circuit logic here to try both sequentially + ( ( include_fp = fopen( include_file_name, "r" ) ) != NULL ) ) + { fprintf(stderr,"including %s\n",include_file_name ) ; pre_parse( dir , include_fp , outfile ) ; fclose( include_fp ) ; - } else { - fprintf(stderr,"Registry warning: cannot open %s. Ignoring.\n", include_file_name ) ; + } + else { + fprintf(stderr,"Registry warning: cannot open %s. Tried %s and %s Ignoring.\n", include_file_name, include_file_name, include_file_name_local_registry ) ; } } } diff --git a/var/build/depend.txt b/var/build/depend.txt index 59e626f662..3d12fee59c 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -136,24 +136,24 @@ da_chem_sfc.o: da_chem_sfc.f90 da_jo_and_grady_chem_sfc.inc da_jo_chem_sfc.inc d da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_lightning.inc da_read_obs_lightning.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_read_obs_chem_sfc.inc da_scan_obs_chem_sfc.inc da_write_obs_chem_sfc.inc da_final_write_obs_chem_sfc.inc da_final_write_obs_gas_sfc.inc da_read_obs_bufr_satwnd.inc da_par_util.o : da_par_util.f90 da_proc_maxmin_combine.inc da_proc_stats_combine.inc da_system.inc da_y_facade_to_global.inc da_generic_boilerplate.inc da_deallocate_global_synop.inc da_deallocate_global_sound.inc da_deallocate_global_sonde_sfc.inc da_generic_methods.inc da_patch_to_global_3d.inc da_patch_to_global_dual_res.inc da_patch_to_global_2d.inc da_cv_to_global.inc da_transpose_y2x_v2.inc da_transpose_x2y_v2.inc da_transpose_z2y.inc da_transpose_y2z.inc da_transpose_x2z.inc da_transpose_z2x.inc da_transpose_y2x.inc da_transpose_x2y.inc da_unpack_count_obs.inc da_pack_count_obs.inc da_copy_tile_dims.inc da_copy_dims.inc da_alloc_and_copy_be_arrays.inc da_vv_to_cv.inc da_cv_to_vv.inc da_generic_typedefs.inc da_wrf_interfaces.o da_tracing.o da_reporting.o da_define_structures.o da_par_util1.o module_dm.o module_domain.o da_control.o da_par_util1.o : da_par_util1.f90 da_proc_sum_real.inc da_proc_sum_ints.inc da_proc_sum_int.inc da_control.o module_state_description.o -da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o +da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_trop_wmo.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o da_pilot.o : da_pilot.f90 da_calculate_grady_pilot.inc da_get_innov_vector_pilot.inc da_check_max_iv_pilot.inc da_transform_xtoy_pilot_adj.inc da_transform_xtoy_pilot.inc da_print_stats_pilot.inc da_oi_stats_pilot.inc da_residual_pilot.inc da_jo_and_grady_pilot.inc da_ao_stats_pilot.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_polaramv.o : da_polaramv.f90 da_calculate_grady_polaramv.inc da_get_innov_vector_polaramv.inc da_check_max_iv_polaramv.inc da_transform_xtoy_polaramv_adj.inc da_transform_xtoy_polaramv.inc da_print_stats_polaramv.inc da_oi_stats_polaramv.inc da_residual_polaramv.inc da_jo_and_grady_polaramv.inc da_ao_stats_polaramv.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_profiler.o : da_profiler.f90 da_calculate_grady_profiler.inc da_get_innov_vector_profiler.inc da_check_max_iv_profiler.inc da_transform_xtoy_profiler_adj.inc da_transform_xtoy_profiler.inc da_print_stats_profiler.inc da_oi_stats_profiler.inc da_residual_profiler.inc da_jo_and_grady_profiler.inc da_ao_stats_profiler.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_pseudo.o : da_pseudo.f90 da_calculate_grady_pseudo.inc da_transform_xtoy_pseudo_adj.inc da_transform_xtoy_pseudo.inc da_print_stats_pseudo.inc da_oi_stats_pseudo.inc da_ao_stats_pseudo.inc da_get_innov_vector_pseudo.inc da_residual_pseudo.inc da_jo_and_grady_pseudo.inc da_tracing.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_adj.inc da_transform_xtoy_qscat.inc da_print_stats_qscat.inc da_oi_stats_qscat.inc da_ao_stats_qscat.inc da_get_innov_vector_qscat.inc da_check_max_iv_qscat.inc da_residual_qscat.inc da_jo_and_grady_qscat.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_rad_diags.o : da_rad_diags.f90 +da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_radzicevar_calc_ice_abc.inc da_radzicevar_pkx.inc da_radzicevar_rain_adj.inc da_radzicevar_virtual.inc da_radzicevar_cal_tl_fw4wetice.inc da_radzicevar_parameter_zrx.inc da_radzicevar_prepare_interceptpara.inc da_radzicevar_rain_tl.inc da_radzicevar_waterfraction.inc da_radzicevar_dryice_adj.inc da_radzicevar_parameter_zxx.inc da_radzicevar_prepare_mixingratios.inc da_radzicevar_rhoair_tl.inc da_radzicevar_wetice_adj.inc da_radzicevar_dryice_tl.inc da_radzicevar_prepare_zmm_adj.inc da_radzicevar_sigma_in_abc.inc da_radzicevar_wetice_tl.inc da_radzicevar_pxabk.inc da_radzicevar_upper_f.inc da_radzicevar.inc da_radzicevar_tl.inc da_radzicevar_adj.inc +da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_sat_angles.inc da_get_sat_angles_1d.inc da_get_solar_angles.inc da_get_solar_angles_1d.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_hdf5gmi.inc da_read_obs_netcdf4ahi_geocat.inc mod_clddet_geoir.o da_read_obs_ncgoesabi.inc +da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_qc_gmi.inc da_qc_goesabi.inc da_lightning.o : da_lightning.f90 da_calculate_grady_lightning.inc da_get_innov_vector_lightning.inc da_check_max_iv_lightning.inc da_transform_xtoy_lightning_adj.inc da_transform_xtoy_lightning.inc da_print_stats_lightning.inc da_oi_stats_lightning.inc da_residual_lightning.inc da_jo_and_grady_lightning.inc da_ao_stats_lightning.inc da_div_profile.inc da_div_profile_adj.inc da_div_profile_tl.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o -da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_hdf5gmi.inc da_read_obs_netcdf4ahi_geocat.inc mod_clddet_geoir.o -da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_qc_gmi.inc da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_transform_through_rf_inv.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_recursive_filter_1d_inv.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_reporting.o : da_reporting.f90 da_message2.inc da_message.inc da_warning.inc da_error.inc da_control.o da_rf_cv3.o : da_rf_cv3.f90 da_mat_cv3.o da_rfz_cv3.o : da_rfz_cv3.f90 da_rsl_interfaces.o : da_rsl_interfaces.f90 -da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o +da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o da_physics.o da_satem.o : da_satem.f90 da_calculate_grady_satem.inc da_get_innov_vector_satem.inc da_check_max_iv_satem.inc da_transform_xtoy_satem_adj.inc da_transform_xtoy_satem.inc da_print_stats_satem.inc da_oi_stats_satem.inc da_residual_satem.inc da_jo_and_grady_satem.inc da_ao_stats_satem.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures_lightning.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_setup_flow_predictors_ep_format2.inc da_setup_flow_predictors_ep_format3.inc da_get_alpha_vertloc.inc da_write_vp.inc module_state_description.o da_setup_obs_structures_chem_sfc.inc da_ships.o : da_ships.f90 da_calculate_grady_ships.inc da_get_innov_vector_ships.inc da_check_max_iv_ships.inc da_transform_xtoy_ships_adj.inc da_transform_xtoy_ships.inc da_print_stats_ships.inc da_oi_stats_ships.inc da_residual_ships.inc da_jo_and_grady_ships.inc da_ao_stats_ships.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o @@ -165,7 +165,7 @@ da_synop.o : da_synop.f90 da_check_buddy_synop.inc da_calculate_grady_synop.inc da_tamdar.o : da_tamdar.f90 da_calculate_grady_tamdar_sfc.inc da_check_max_iv_tamdar_sfc.inc da_get_innov_vector_tamdar_sfc.inc da_transform_xtoy_tamdar_sfc_adj.inc da_transform_xtoy_tamdar_sfc.inc da_print_stats_tamdar_sfc.inc da_oi_stats_tamdar_sfc.inc da_residual_tamdar_sfc.inc da_jo_tamdar_sfc_uvtq.inc da_jo_and_grady_tamdar_sfc.inc da_ao_stats_tamdar_sfc.inc da_calculate_grady_tamdar.inc da_get_innov_vector_tamdar.inc da_check_max_iv_tamdar.inc da_transform_xtoy_tamdar_adj.inc da_transform_xtoy_tamdar.inc da_print_stats_tamdar.inc da_oi_stats_tamdar.inc da_residual_tamdar.inc da_jo_tamdar_uvtq.inc da_jo_and_grady_tamdar.inc da_ao_stats_tamdar.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_varbc_tamdar.o da_varbc_tamdar.o : da_varbc_tamdar.f90 da_varbc_tamdar_init.inc da_varbc_tamdar_pred.inc da_varbc_tamdar_precond.inc da_varbc_tamdar_direct.inc da_varbc_tamdar_adj.inc da_varbc_tamdar_tl.inc da_varbc_tamdar_update.inc da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_define_structures.o da_control.o module_dm.o da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_lightning.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc da_check_cvtovv_adjoint_chem.inc da_check_vtox_adjoint_chem.inc da_check_vchemtox_adjoint.inc -da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc +da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_llxy_1d.inc da_llxy_default_1d.inc da_llxy_global_1d.inc da_llxy_kma_global_1d.inc da_llxy_latlon_1d.inc da_llxy_lc_1d.inc da_llxy_merc_1d.inc da_llxy_ps_1d.inc da_llxy_rotated_latlon_1d.inc da_llxy_wrf_1d.inc da_togrid_1d.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_wrf_interfaces.o da_radar.o da_lightning.o da_transfer_wrftoxb_chem.inc diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index 095c5dbcb7..2ecff3eaaa 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -574,10 +574,12 @@ module da_define_structures real, pointer :: vtox(:,:) end type varbc_type type clddet_geoir_type - real :: RTCT, RFMFT, TEMPIR, terr_hgt - real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 - real :: CIRH2O - !real, allocatable :: CIRH2O(:,:,:) + real :: RTCT, RFMFT, TEMPIR, terr_hgt ! for both ABI and AHI + real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 ! only for AHI + real :: CIRH2O ! for both ABI and AHI + real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI + real, allocatable :: tb_stddev_3x3(:) ! only for ABI + integer :: RFMFT_ij(2) ! only for ABI end type clddet_geoir_type type superob_type real, allocatable :: tb_obs(:,:) @@ -618,6 +620,8 @@ module da_define_structures integer, pointer :: cloud_flag(:,:) integer, pointer :: cloudflag(:) integer, pointer :: rain_flag(:) + real, pointer :: cloud_mod(:,:) ! only for ABI + real, pointer :: cloud_obs(:,:) ! only for ABI real, allocatable :: cloud_frac(:) real, pointer :: satzen(:) real, pointer :: satazi(:) @@ -632,10 +636,10 @@ module da_define_structures real, pointer :: lod(:,:,:) ! layer_optical_depth real, pointer :: trans(:,:,:) ! layer transmittance real, pointer :: der_trans(:,:,:) ! d(transmittance)/dp - real, pointer :: kmin_t(:) - real, pointer :: kmax_p(:) - real, pointer :: sensitivity_ratio(:,:,:) - real, pointer :: p_chan_level(:,:) + real, pointer :: kmin_t(:) + real, pointer :: kmax_p(:) + real, pointer :: sensitivity_ratio(:,:,:) + real, pointer :: p_chan_level(:,:) real, pointer :: qrn(:,:) real, pointer :: qcw(:,:) real, pointer :: qci(:,:) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index af42a488ff..6d2db8f686 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -42,7 +42,7 @@ program da_rad_diags integer :: ncid, dimid, varid integer, dimension(3) :: ishape, istart, icount ! - logical :: amsr2 + logical :: amsr2, abi logical :: isfile, prf_found, jac_found integer, parameter :: datelen1 = 10 integer, parameter :: datelen2 = 19 @@ -62,9 +62,9 @@ program da_rad_diags real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp, cloud_frac real*4, dimension(:), allocatable :: cip ! cloud-ice path integer, dimension(:), allocatable :: cloudflag ! cloudflag from L2 AHI - integer, dimension(:,:), allocatable :: tb_qc + integer, dimension(:,:), allocatable :: tb_qc, cloud_flag real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac - real*4, dimension(:,:), allocatable :: tb_bak_clr ! clear-sky brightness temp + real*4, dimension(:,:), allocatable :: cloud_mod, cloud_obs, tb_bak_clr ! clear-sky brightness temp real*4, dimension(:,:), allocatable :: weightfunc_peak ! peak of weighting function real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water real*4, dimension(:,:), allocatable :: prf_ice, prf_rain, prf_snow, prf_grau, prf_hail @@ -139,6 +139,7 @@ program da_rad_diags write(0,*) trim(instid(iinst)) amsr2 = index(instid(iinst),'amsr2') > 0 + abi = index(instid(iinst),'abi') > 0 nerr = 0 total_npixel = 0 @@ -263,6 +264,12 @@ program da_rad_diags allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) + if ( abi ) then + allocate ( cloud_mod(1:nchan,1:total_npixel) ) + allocate ( cloud_obs(1:nchan,1:total_npixel) ) + allocate ( cloud_flag(1:nchan,1:total_npixel)) + cloud_flag = 0 + end if allocate ( ems(1:nchan,1:total_npixel) ) if ( jac_found ) then allocate ( ems_jac(1:nchan,1:total_npixel) ) @@ -333,6 +340,11 @@ program da_rad_diags tb_inv = missing_r tb_oma = missing_r tb_err = missing_r + if ( abi ) then + cloud_mod = missing_r + cloud_obs = missing_r + end if + ncname = 'diags_'//trim(instid(iinst))//"_"//datestr1(itime)//'.nc' ios = NF_CREATE(trim(ncname), NF_NETCDF4, ncid) ! Change to output netcdf4 files !ios = NF_CREATE(trim(ncname), NF_CLOBBER, ncid) ! NF_CLOBBER specifies the default behavior of @@ -392,7 +404,15 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, cloud_flag for abi + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_obs(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS + read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! cloud_flag + end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) cycle npixel_loop @@ -523,6 +543,13 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) + if ( abi ) then + ios = NF_DEF_VAR(ncid, 'cloud_mod', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_obs', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_flag', NF_INT, 2, ishape(1:2), varid) + end if ! ! define 2-D array with dimensions nlev * total_npixel ! @@ -669,6 +696,14 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) + if ( abi ) then + ios = NF_INQ_VARID (ncid, 'cloud_mod', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_mod) + ios = NF_INQ_VARID (ncid, 'cloud_obs', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_obs) + ios = NF_INQ_VARID (ncid, 'cloud_flag', varid) + ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), cloud_flag) + end if ! ! output 2-D array with dimensions nlev * total_npixel ! @@ -890,6 +925,11 @@ program da_rad_diags deallocate ( tb_bak_clr ) deallocate ( weightfunc_peak ) deallocate ( tb_inv ) + if ( abi ) then + deallocate ( cloud_mod ) + deallocate ( cloud_obs ) + deallocate ( cloud_flag ) + end if deallocate ( tb_oma ) deallocate ( ems ) if ( jac_found ) deallocate ( ems_jac ) diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index d5b5eb61ad..947498601b 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -80,6 +80,10 @@ subroutine da_allocate_rad_iv (i, nchan, iv) end if if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then allocate (iv%instid(i)%cloudflag(iv%instid(i)%num_rad)) + end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + allocate (iv%instid(i)%cloud_mod(nchan,iv%instid(i)%num_rad)) + allocate (iv%instid(i)%cloud_obs(nchan,iv%instid(i)%num_rad)) end if if ( index(iv%instid(i)%rttovid_string, 'gmi') > 0 ) then allocate (iv%instid(i)%clw(iv%instid(i)%num_rad)) @@ -112,16 +116,26 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) allocate (iv%instid(i)%cloud_frac(iv%instid(i)%num_rad)) if ( use_clddet_zz ) then - iv%instid(i)%superob_width = 2*ahi_superob_halfwidth+1 + ! here we assume AHI and ABI (they cover different regions) are not used simultaneously + if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) & + iv%instid(i)%superob_width = 2*ahi_superob_halfwidth+1 + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) & + iv%instid(i)%superob_width = 2*abi_superob_halfwidth+1 + allocate (iv%instid(i)%superob(iv%instid(i)%superob_width, & iv%instid(i)%superob_width)) do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width allocate (iv%instid(i)%superob(ix,iy)%cld_qc(iv%instid(i)%num_rad)) allocate (iv%instid(i)%superob(ix,iy)%tb_obs(nchan,iv%instid(i)%num_rad)) + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do n = 1, iv%instid(i)%num_rad + allocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(nchan)) + end do + end if end do end do - end if + end if if ( use_rttov_kmatrix .or. use_crtm_kmatrix ) then allocate(iv%instid(i)%ts_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ps_jacobian(nchan,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index e0e9f71b55..1ba3834654 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -38,6 +38,13 @@ deallocate ( satinfo(i) % clearSkyBias) endif + ! Deallocate extra variables for ABI + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (satinfo(i) % error_cld_y) + deallocate (satinfo(i) % error_cld_x) + endif + + if (use_error_factor_rad) then deallocate (satinfo(i) % error_factor) endif @@ -115,6 +122,10 @@ end if if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then deallocate (iv%instid(i)%cloudflag) + end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (iv%instid(i)%cloud_mod) + deallocate (iv%instid(i)%cloud_obs) end if if ( index(iv%instid(i)%rttovid_string,'gmi') > 0 ) then deallocate (iv%instid(i)%clw) @@ -149,8 +160,16 @@ if ( use_clddet_zz ) then do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width - deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) - deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do n = 1,iv%instid(i)%num_rad + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) + end do + end if + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) + deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) end do end do deallocate (iv%instid(i)%superob) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index d41260953d..17a8d4c635 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -92,7 +92,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) real, allocatable :: hessian(:,:) real*8, allocatable :: eignvec(:,:), eignval(:) real :: rad_clr, rad_ovc_ilev, rad_ovc_jlev - + integer :: Band_Size(5), Bands(AIRS_Max_Channels,5) !For Zhuge and Zou cloud detection real, allocatable :: geoht_full(:,:,:) @@ -243,9 +243,10 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) calc_tb_clr = .false. if ( crtm_cloud .and. & ( trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' .or. & + trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' .or. & trim( crtm_sensor_name(rtminit_sensor(inst))) == 'ahi') ) then !Tb_clear_sky is only needed for symmetric obs error model - !symmetric obs error model only implemented for amsr2 for now + !symmetric obs error model only implemented for amsr2 & abi/ahi for now calc_tb_clr = .true. end if @@ -443,7 +444,6 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) end if - call da_interp_2d_partial (grid%xb%u10, iv%instid(inst)%info, 1, n, n, model_u10(n:n)) call da_interp_2d_partial (grid%xb%v10, iv%instid(inst)%info, 1, n, n, model_v10(n:n)) call da_interp_2d_partial (grid%xb%psfc, iv%instid(inst)%info, 1, n, n, model_psfc(n:n)) @@ -476,6 +476,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do + !if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + ! write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ! ' where all observed BTs are < 0' + ! call da_warning(__FILE__,__LINE__,message(1:1)) + ! iv%instid(inst)%tb_inv(:,n) = missing_r + ! iv%instid(inst)%info%proc_domain(:,n) = .false. + ! cycle pixel_loop + !end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud) then diff --git a/var/da/da_radiance/da_get_innov_vector_rttov.inc b/var/da/da_radiance/da_get_innov_vector_rttov.inc index ac78014a08..3f4dce9799 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -49,12 +49,30 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) real, allocatable :: em_mspps(:) ! emissivity caluclated using MSPPS algorithm real :: ts_mspps ! surface temperature calcualted using MSPPS algorithm + !For Zhuge and Zou cloud detection + real, allocatable :: geoht_full(:,:,:) + real :: geoht_pixel(kts:min(kte,kme-1)) + real :: tt_pixel(kts:min(kte,kme-1)) + real :: pp_pixel(kts:min(kte,kme-1)) + if (trace_use) call da_trace_entry("da_get_innov_vector_rttov") !------------------------------------------------------ ! [1.0] calculate the background bright temperature !------------------------------------------------------- + if ( use_clddet_zz ) then + allocate ( geoht_full(ims:ime,jms:jme,kms:kme-1) ) + do k = kms, kme-1 + do j = jms, jme + do i = ims, ime + geoht_full(i,j,k) = 0.5 * ( grid%ph_2(i,j,k) + grid%phb(i,j,k) + & + grid%ph_2(i,j,k+1) + grid%phb(i,j,k+1) ) / gravity + end do + end do + end do + end if + do inst = 1, iv%num_inst ! loop for sensor if ( iv%instid(inst)%num_rad < 1 ) cycle nlevels = iv%instid(inst)%nlevels @@ -99,7 +117,6 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) call da_interp_lin_3d (grid%xb%t, iv%instid(inst)%info, iv%instid(inst)%t (:,n1:n2)) call da_interp_lin_3d (grid%xb%q, iv%instid(inst)%info, iv%instid(inst)%mr(:,n1:n2)) - do n= n1,n2 do k=1, nlevels if (iv%instid(inst)%info%zk(k,n) <= 0.0) then @@ -132,6 +149,19 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%surftype(n) = 0 end if + if ( use_clddet_zz ) then + ! Find tropopause temperature for Zhuge and Zou Cloud Detection + do k = kts, min(kte,kme-1) + call da_interp_2d_partial ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) + call da_interp_2d_partial ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) + call da_interp_2d_partial ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + +! call da_interp_lin_2d ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) +! call da_interp_lin_2d ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) +! call da_interp_lin_2d ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + end do + call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) + end if end do call da_interp_lin_2d (grid%xb % u10, iv%instid(inst)%info, 1, iv%instid(inst)%u10(n1:n2)) @@ -381,6 +411,8 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) end do ! end loop for sensor + if ( use_clddet_zz ) deallocate ( geoht_full ) + if (trace_use) call da_trace_exit("da_get_innov_vector_rttov") #else call da_error(__FILE__,__LINE__, & diff --git a/var/da/da_radiance/da_get_sat_angles.inc b/var/da/da_radiance/da_get_sat_angles.inc new file mode 100644 index 0000000000..440d13e8f3 --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles.inc @@ -0,0 +1,100 @@ +subroutine da_get_sat_angles ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Menthod: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat,lon + integer, intent(in) :: sate_index + real, intent(out) :: satzen + real, optional, intent(out) :: satazi + + real(r_double) :: alat, alon, alon_sat + real(r_double) :: theta, r_tmp, theta_tmp, gam, beta + + satzen = missing_r + if ( present( satazi ) ) satazi = missing_r + + if ( lat .ge. 90. .or. & + lat .le. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + return + end if + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then +! alon_sat = -75.2 * deg2rad !True Value? + alon_sat = -75. * deg2rad !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137. * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon-alon_sat + + ! Yang et al., 2017 + + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos(gam) ) + + if (r_tmp .lt. 0) return + + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + + + ! azimuth + if ( present(satazi) ) then + beta = tan(alat) / tan(gam) + if (beta.gt.1.D0 .and. beta.lt.1.00000001D0) beta = 1.0D0 + beta = acos( beta ) / deg2rad !to degrees + + if ( lat.lt.0. .and. theta.le.0. ) & + satazi = beta + if ( lat.ge.0. .and. theta.le.0. ) & + satazi = 180.d0 - beta + if ( lat.ge.0. .and. theta.gt.0. ) & + satazi = 180.d0 + beta + if ( lat.lt.0. .and. theta.gt.0. ) & + satazi = 360.d0 - beta + end if + + return + +end subroutine da_get_sat_angles diff --git a/var/da/da_radiance/da_get_sat_angles_1d.inc b/var/da/da_radiance/da_get_sat_angles_1d.inc new file mode 100644 index 0000000000..64b65d71cf --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles_1d.inc @@ -0,0 +1,132 @@ +subroutine da_get_sat_angles_1d ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Method: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:),lon(:) + integer, intent(in) :: sate_index + real, intent(out) :: satzen(:) + real, optional, intent(out) :: satazi(:) + + integer :: n + real(r_double) :: alon_sat + real(r_double), allocatable :: alat(:), alon(:) + real(r_double), allocatable :: theta(:), r_tmp(:), theta_tmp(:), gam(:) + real(r_double), allocatable :: beta(:) + logical, allocatable :: valid_loc(:) + + satzen = missing_r + if (present(satazi)) satazi = missing_r + + n = size(lat) + if (n.le.0) return + + allocate( alat(n) ) + allocate( alon(n) ) + allocate( theta(n) ) + allocate( r_tmp(n) ) + allocate( theta_tmp(n) ) + allocate( gam(n) ) + allocate( valid_loc(n) ) + + !Define valid locations for vectorized operations + valid_loc = ( lat .lt. 90. .and. & + lat .gt. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then + alon_sat = -75.2 * deg2rad + else if (sate_index .eq. 17) then + alon_sat = -137.2 * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + where ( valid_loc ) + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon - alon_sat + elsewhere + alat = missing_r + alon = missing_r + theta = missing_r + gam = missing_r + r_tmp = missing_r + end where + + ! Yang et al., 2017 + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + where ( valid_loc ) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos( gam ) ) + end where + + valid_loc = (valid_loc .and. r_tmp.ge.0) + + where ( valid_loc ) + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + end where + + + ! azimuth + if ( present(satazi) ) then + allocate( beta(n) ) + beta = missing_r + where ( valid_loc ) & + beta = tan(alat) / tan(gam) + where ( beta.gt.1._r_double .and. & + beta.lt.1.00000001_r_double .and. valid_loc ) & + beta = 1.0_r_double + where ( valid_loc ) & + beta = acos( beta ) / deg2rad !to degrees + where ( lat.lt.0. .and. theta.le.0. .and. valid_loc ) & + satazi = beta + where ( lat.ge.0. .and. theta.le.0. .and. valid_loc ) & + satazi = 180.d0 - beta + where ( lat.ge.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 180.d0 + beta + where ( lat.lt.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 360.d0 - beta + deallocate( beta ) + end if + + deallocate( alat, alon, theta, r_tmp, theta_tmp, gam, valid_loc ) + + return + +end subroutine da_get_sat_angles_1d diff --git a/var/da/da_radiance/da_get_solar_angles.inc b/var/da/da_radiance/da_get_solar_angles.inc new file mode 100644 index 0000000000..0f1fc12b01 --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles.inc @@ -0,0 +1,215 @@ +subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat + real, intent(in) :: lon + real, intent(out) :: solazi + real, intent(out) :: solzen + + real(r_double) :: latrad + real(r_double) :: delta, ju, jmod, time, gmst, lmst + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec, ha + real(r_double) :: elev, refrac !, elc + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + solzen = missing_r + solazi = missing_r + if ( lat .gt. 90. .or. & + lat .lt. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + return + end if + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if ( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if ( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + ! (asin varies between -pi/2 to pi/2) + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if ( gmst.lt.0. ) gmst = gmst + 24. + + ! Calculate local mean sidereal time in radians + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + if ( lmst.lt.0. ) lmst = lmst + 24. + lmst = lmst * 15. * deg2rad + + + ! Calculate hour angle in radians between -pi and pi + ha = lmst - ra + if ( ha .lt. -PI ) ha = ha + 2.0*PI + if ( ha .gt. PI ) ha = ha - 2.0*PI + + ! Change latitude to radians + latrad = lat * deg2rad + + ! From this point on: + ! mnlon in degs, gmst in hours, ju in days minus 2.4e6; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + + ! Night-time angles are inconsequential + if ( elev < 0. ) return + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! if ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! if ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! else +! solazi = PI - solazi +! endif + + +! ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !ORIGINAL: + !elc = asin( sin( dec ) / sin( latrad ) ) + !if ( elev.ge.elc ) solazi = PI - solazi + !if ( elev.le.elc .and. ha.gt.0. ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + if ( cos(ha) < ( tan(dec) / tan(latrad) ) ) then + solazi = 2.0*PI + solazi + else + solazi = PI - solazi + end if + + ! Convert az to degs, force between 0 and 2*pi + solazi = solazi / deg2rad + solazi = mod( solazi, 360. ) + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs before calculating correction) + elev = elev / deg2rad + + !JJG: Added these bounds (should not need them) + !Keep elevation between -90. to +90. + if ( elev.lt.-90. ) & + elev = - (180. + elev) + if ( elev.gt.90. ) & + elev = 180. - elev + +! ! Michalsky (1988) +! if ( elev.gt. - 0.56 ) then +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! else +! refrac = 0.56 +! endif + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + if ( elev.ge.19.225 ) then + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + else if ( elev.gt.-0.766 .and. elev.lt.19.225 ) then + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + else + refrac = 0.0 + end if + + ! note that 3.51579=1013.25 mb/288.2 C + + elev = elev + refrac + + ! Convert elevation to topocentric zenith + solzen = 90.0_r_kind - elev + +end subroutine da_get_solar_angles diff --git a/var/da/da_radiance/da_get_solar_angles_1d.inc b/var/da/da_radiance/da_get_solar_angles_1d.inc new file mode 100644 index 0000000000..aff7a519b5 --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles_1d.inc @@ -0,0 +1,253 @@ +subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: solazi(:) + real, intent(out) :: solzen(:) + + real(r_double), allocatable :: latrad(:) + real(r_double) :: delta, ju, jmod, time, gmst + + real(r_double), allocatable :: lmst(:), ha(:) + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec + real(r_double), allocatable :: elev(:), refrac(:) !, elc(:) + logical, allocatable :: valid_loc(:) + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + + integer :: n + + n = size(lat) + allocate( latrad(n) ) + allocate( lmst(n) ) + allocate( ha(n) ) + allocate( elev(n) ) +! allocate( elc(n) ) + allocate( refrac(n) ) + allocate( valid_loc(n) ) + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if( gmst.lt.0. ) gmst = gmst + 24. + + !Define valid locations for vectorized operations + valid_loc = ( lat .le. 90. .and. & + lat .ge. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + ! Calculate local mean sidereal time in radians + where ( valid_loc ) + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + end where + where ( lmst.lt.0. .and. valid_loc ) + lmst = lmst + 24. + end where + where ( valid_loc ) + lmst = lmst * 15. * deg2rad + end where + + + ! Calculate hour angle in radians between -pi and pi + where ( valid_loc ) + ha = lmst - ra + end where + where ( ha .lt. -PI .and. valid_loc ) ha = ha + 2.0*PI + where ( ha .gt. PI .and. valid_loc ) ha = ha - 2.0*PI + + ! Change latitude to radians + latrad = missing_r + where ( valid_loc ) + latrad = lat * deg2rad + end where + + ! From this point on: + ! mnlon in degs, gmst in hours, jd in days if 2.4e6 added; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) + where ( valid_loc ) + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + end where + + ! Night-time angles are inconsequential + valid_loc = (valid_loc .and. elev.ge.0.) + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) + solazi = missing_r + where ( valid_loc ) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + end where + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! where ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! where ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! elsewhere +! solazi = PI - solazi +! endif + + ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !where ( valid_loc ) + ! elc = asin( sin( dec ) / sin( latrad ) ) + !end where + !where ( elev.ge.elc .and. valid_loc ) solazi = PI - solazi + !where ( elev.le.elc .and. ha.gt.0. .and. valid_loc ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + where ( valid_loc .and. cos(ha) < ( tan(dec) / tan(latrad) ) ) + solazi = 2.0*PI + solazi + elsewhere ( valid_loc ) + solazi = PI - solazi + end where + + ! Convert az to degs, force between 0 and 2*pi + where ( valid_loc ) + solazi = solazi / deg2rad + end where + solazi = mod( solazi, 360. ) + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs before calculating correction) + where ( valid_loc ) + elev = elev / deg2rad + end where + + !JJG: Added these bounds (should not need them) + !Keep elevation between -90. to +90. + where ( valid_loc .and. elev.lt.-90.) & + elev = - (180. + elev) + where ( valid_loc .and. elev.gt.90.) & + elev = 180. - elev + +! ! Michalsky (1988) +! where ( elev.gt. - 0.56 ) +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! elsewhere +! refrac = 0.56 +! end where + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + where ( elev.ge.19.225 ) + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + elsewhere ( elev.gt.-0.766 .and. elev.lt.19.225 ) + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + elsewhere + refrac = 0.0 + end where + ! note that 3.51579=1013.25 mb/288.2 C + + where ( valid_loc ) + elev = elev + refrac + end where + + + ! Convert elevation to topocentric zenith + solzen = missing_r + where (valid_loc) + solzen = 90.0_r_kind - elev + end where + + deallocate( latrad, lmst, ha, elev, refrac, valid_loc ) + +end subroutine da_get_solar_angles_1d diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 8c6de31102..4cc7740f33 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -93,6 +93,11 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%tb_imp(:,n) = 0.0 iv%instid(i)%rad_xb(:,n) = 0.0 iv%instid(i)%rad_obs(:,n) = 0.0 + !if ( associated( p % rad_obs ) ) then + ! iv%instid(i)%rad_obs(:,n) = p%rad_obs(:) + !else + ! iv%instid(i)%rad_obs(:,n) = 0.0 + !end if iv%instid(i)%rad_ovc(:,:,n) = 0.0 iv%instid(i)%emiss(:,n) = 0.0 iv%instid(i)%scanpos(n) = p%scanpos @@ -113,14 +118,20 @@ subroutine da_initialize_rad_iv (i, n, iv, p) do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width iv%instid(i)%superob(ix,iy)%tb_obs(:,n) = p % superob(ix,iy) % tb_obs(:,1) - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR + if (index(iv%instid(i)%rttovid_string, 'abi') > 0) then + if ( allocated ( p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3 ) ) & + iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(:) = p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3(:) + end if + if (index(iv%instid(i)%rttovid_string, 'ahi') > 0) then iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_10 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_10 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_13 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_13 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_14 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_14 + end if + iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt - iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O end do end do end if diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc new file mode 100644 index 0000000000..ec860279e9 --- /dev/null +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -0,0 +1,706 @@ +subroutine da_qc_goesabi (it, isens, nchan, ob, iv) + + !--------------------------------------------------------------------------- + ! Purpose: perform quality control for abi data. + ! To be developed: built in cloud_detection method + !--------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: it ! outer loop count + integer, intent(in) :: isens ! sensor index. + integer, intent(in) :: nchan ! number of channel + type (y_type), intent(in) :: ob ! Observation structure. + type (iv_type), intent(inout) :: iv ! O-B structure. + + ! local variables + logical :: lmix, cloud_detection + integer :: n,k,isflg,ios,fgat_rad_unit + integer :: ngood(nchan),nrej(nchan),nrej_omb_abs(nchan), & + nrej_omb_std(nchan),nrej_eccloud(nchan), & + nrej_clw(nchan),num_proc_domain, & + nrej_mixsurface,nrej_land + + ! isflg: SEA(0),ICE(1),LAND(2),SNOW(3),MSEA(4),MICE(5),MLND(6),MSNO(7) + integer, parameter :: sea_flag = 0 + integer, parameter :: ice_flag = 1 + integer, parameter :: land_flag = 2 + integer, parameter :: snow_flag = 3 + integer, parameter :: msea_flag = 4 + integer, parameter :: mice_flag = 5 + integer, parameter :: mland_flag = 6 + integer, parameter :: msnow_flag = 7 + +! ------- + real :: inv_grosscheck + + character(len=30) :: filename + + logical :: print_cld_debug + + !! Additional variables used by Harnish, Weissmann, & Perianez (2016) + real :: BTlim(nchan), cloud_mean(nchan) + real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) + integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc + real, parameter :: camin = 0.0 !Harnisch et al. (2016) + !real, parameter :: camin = 0.5 !Okamoto et al. (2013) + + !! Additional variables used by Zhuge and Zou (2017) + integer :: itest + logical :: reject_clddet + real :: crit_clddet + real :: rad_O14, rad_M14, rad_tropt + real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 + real :: Relaz, Glintzen + real :: wave_num(10) + real :: plbc1(10), plbc2(10) + real :: plfk1(10), plfk2(10) + integer, parameter :: num_clddet_tests = 10 + integer, parameter :: num_clddet_cats = 4 + real :: eps_clddet(num_clddet_tests+2,num_clddet_cats) + integer :: index_clddet(num_clddet_tests), offset_clddet + integer :: isflgs_clddet(num_clddet_cats) + logical :: qual_clddet(num_clddet_cats) + character(len=10) :: crit_names_clddet(num_clddet_tests) + integer :: nrej_clddet(nchan,num_clddet_tests) + integer :: superob_center + integer*2 :: clddet_tests(iv%instid(isens)%superob_width, & + iv%instid(isens)%superob_width, & + num_clddet_tests) + integer :: isuper, jsuper + + real, pointer :: tb_obs(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), & + cloud_obs(:,:), cloud_mod(:,:) + integer :: tb_qc(nchan) + + real :: big_num + + ! note: these values are constant across channels + real, parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 + real, parameter :: C2=1.43877516 ! = h * c / b = 1.43877 K(cm-1)-1 + ! h = Planck's constant + ! b = Boltzmann constant + ! c = velocity of light + + integer, parameter :: ch7 = 1 + integer, parameter :: ch10 = 4 + integer, parameter :: ch14 = 8 + integer, parameter :: ch15 = 9 + + if (trace_use) call da_trace_entry("da_qc_goesabi") + +!! if (iv%instid(isens)%num_rad <= 0) return + + ! These values can change as SRF (spectral response function) is updated + ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 + wave_num(1:10) = (/2570.373, 1620.528, 1443.554, 1363.228, 1184.220, & + 1040.891, 968.001, 894.000, 815.294, 753.790/) + plbc1(1:10) = (/0.43361, 1.55228, 0.34427, 0.05651, 0.18733, & + 0.09102, 0.07550, 0.22516, 0.21702, 0.06266/) + plbc2(1:10) = (/0.99939, 0.99667, 0.99918, 0.99986, 0.99948, & + 0.99971, 0.99975, 0.99920, 0.99916, 0.99974/) + + plfk1 = C1 * wave_num**3 + plfk2 = C2 * wave_num + + crit_names_clddet(1) = "rtct" + crit_names_clddet(2) = "etrop" + crit_names_clddet(3) = "pfmft" + crit_names_clddet(4) = "nfmft" + crit_names_clddet(5) = "rfmft" + crit_names_clddet(6) = "cirh2o" + crit_names_clddet(7) = "emiss4" + crit_names_clddet(8) = "ulst" + crit_names_clddet(9) = "notc" + crit_names_clddet(10) = "tempir" + + big_num = huge(big_num) + !! Table 4 from Zhuge X. and Zou X. JAMC, 2016. [modified from ABI Cloud Mask Algorithm] + !ocean land snow ice (assume same as snow) + eps_clddet = transpose( reshape( (/ & + 3.2, 4.1, big_num, big_num & + , 0.1, 0.3, 0.4, 0.4 & + , 0.8, 2.5, 1.0, 1.0 & + , 1.0, 2.0, 5.0, 5.0 & + , 0.7, 1.0, big_num, big_num & + , 0.7, 0.7, 0.7, 0.7 & + , 0.1, 0.46, 0.3, 0.3 & ! Land values: 0.46 in ABI CM; 0.2 in ZZ16 + , 2.86, big_num, big_num, big_num & + , 0.05, 0.1, 0.12, 0.12 & + , 15., 21., 10., 10. & + , 11., 15., 4.5, 4.5 & + , 2.0, 2.0, 2.0, 2.0 & + /), (/ size(eps_clddet, 2), size(eps_clddet, 1) /)) ) + index_clddet = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) + isflgs_clddet = (/sea_flag, land_flag, snow_flag, ice_flag/) + + + ngood(:) = 0 + nrej(:) = 0 + nrej_omb_abs(:) = 0 + nrej_omb_std(:) = 0 + nrej_eccloud(:) = 0 + nrej_clw(:) = 0 + nrej_mixsurface = 0 + nrej_land = 0 + num_proc_domain = 0 + + nrej_clddet = 0 + + tb_xb => iv%instid(isens)%tb_xb + tb_inv => iv%instid(isens)%tb_inv + +! print_cld_debug = .true. + print_cld_debug = .false. + + inv_grosscheck = 15.0 + if ( crtm_cloud ) inv_grosscheck = 80.0 + if ( use_satcv(2) ) inv_grosscheck = 100.0 + + if ( crtm_cloud ) then + tb_xb_clr => iv%instid(isens)%tb_xb_clr + + !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis + BTlim(1) = 269.5 +!3km 2/3 CONUS stats 01 MAY 2018 (mean) + BTlim(2) = 237.0 + BTlim(3) = 249.0 + BTlim(4) = 261.0 +!3km 2/3 CONUS stats 01 MAY 2018 (median) +! BTlim(2) = 231.5 +! BTlim(3) = 240.0 +! BTlim(4) = 250.5 + BTlim(5) = 271.0 + BTlim(6) = 258.0 + BTlim(7) = 272.0 + BTlim(8) = 268.0 + BTlim(9) = 270.5 + BTlim(10) = 258.0 + + cloud_obs => iv%instid(isens)%cloud_obs + cloud_obs = missing_r + + cloud_mod => iv%instid(isens)%cloud_mod + cloud_mod = missing_r + else + tb_xb_clr => iv%instid(isens)%tb_xb + end if + + superob_center = abi_superob_halfwidth + 1 + + ABIPixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 + tb_obs => ob%instid(isens)%tb + + if (iv%instid(isens)%info%proc_domain(1,n)) & + num_proc_domain = num_proc_domain + 1 + + ! 0.0 initialise QC by flags assuming good obs + !----------------------------------------------------------------- + tb_qc = qc_good + iv%instid(isens)%cloud_flag(:,n) = 0 + + ! 1.0 reject all channels over mixed surface type + !------------------------------------------------------ + isflg = iv%instid(isens)%isflg(n) + lmix = (isflg==msea_flag) .or. & + (isflg==mland_flag) .or. & + (isflg==msnow_flag) .or. & + (isflg==mice_flag) + + if (lmix) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_mixsurface = nrej_mixsurface + 1 + end if + + if ( isflg .ne. sea_flag ) then + do k = 1, nchan + if ( all(k .ne. (/ 2, 3, 4 /)) .and. only_sea_rad ) then + tb_qc(k) = qc_bad + nrej_land = nrej_land + 1 + end if + end do + end if + + ! 2.0 check iuse + !----------------------------------------------------------------- + where (satinfo(isens)%iuse(:) == -1) tb_qc = qc_bad + + ! 3.0 check cloud + !----------------------------------------------------------------- + if (.not. crtm_cloud ) then + if (iv%instid(isens)%clwp(n) >= 0.2) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_clw(:) = nrej_clw(:) + 1 + end if + + cloud_detection=.false. + if (cloud_detection) then + if (iv%instid(isens)%landsea_mask(n) == 0 ) then + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 3.5) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + else + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 2.5) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + end if + end if + end if + + abi_clddet: if ( use_clddet_zz ) then + + !!=============================================================================== + !!=============================================================================== + !! + !! 4.0 ABI IR-only Cloud Mask Algorithm, combines: + !! (*) Heidinger A. and Straka W., ABI Cloud Mask, version 3.0, 11 JUN, 2013. + !! (*) Zhuge X. and Zou X. JAMC, 2016. + !! + !!=============================================================================== + !!=============================================================================== + +!JJGDEBUG +! print_cld_debug = iv%instid(isens)%info%proc_domain(1,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & + tb_inv(:,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & + tb_xb_clr(:,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & + tb_obs(:,n) + if (crtm_cloud ) then + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & + tb_xb_clr(:,n) + end if + + if (print_cld_debug) write(stdout,'(A,I8,8F12.4,2x,A)') 'PIXEL_DEBUG5: ', n, & + iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & + iv%instid(isens)%satzen(n), iv%instid(isens)%satazi(n), & + iv%instid(isens)%solzen(n), iv%instid(isens)%solazi(n), & + iv%instid(isens)%tropt(n), iv%instid(isens)%superob(superob_center,superob_center)%cld_qc(n)%terr_hgt, & + iv%instid(isens)%info%date_char(n) +!JJGDEBUG + + + ! Assume tb_xb_clr (central pixel) is applicable to all super-obbed pixels + if (tb_xb_clr(ch7,n) > 0.) then + rad_b_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch7,n) ) ) - 1.0 ) + else + rad_b_ch7 = missing_r + end if + + if (tb_xb_clr(ch14,n) > 0.) then + rad_b_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch14,n) ) ) - 1.0 ) + else + rad_b_ch14 = missing_r + end if + + if ( tb_xb_clr(ch14,n) > 0. ) then + rad_M14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_xb_clr(ch14,n)) ) - 1.0 ) + else + rad_M14 = missing_r + end if + if ( iv%instid(isens)%tropt(n) > 0. ) then + rad_tropt = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * iv%instid(isens)%tropt(n)) ) - 1.0 ) + else + rad_tropt = missing_r + end if + + clddet_tests = 0 + do jsuper = 1, iv%instid(isens)%superob_width + do isuper = 1, iv%instid(isens)%superob_width + ! Use tb_obs for this particular super-ob pixel + + tb_obs => iv%instid(isens)%superob(isuper,jsuper)%tb_obs + + if (tb_obs(ch7,n) > 0.) then + rad_o_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch7,n) ) ) - 1.0 ) + else + rad_o_ch7 = missing_r + end if + if (tb_obs(ch14,n) > 0.) then + rad_o_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch14,n) ) ) - 1.0 ) + rad_O14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / ( plbc1(ch14) + plbc2(ch14) * tb_obs(ch14,n) ) ) - 1.0 ) + else + rad_o_ch14 = missing_r + rad_O14 = missing_r + end if + + + ABICloudTestLoop: do itest = 1, num_clddet_tests + qual_clddet = .true. + offset_clddet = 0 + crit_clddet = missing_r + + select case (itest) + case (1) + !-------------------------------------------------------------------------- + ! 4.1 Relative Thermal Contrast Test (RTCT) + !-------------------------------------------------------------------------- + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RTCT + qual_clddet(3:4) = .false. + + case (2) + !-------------------------------------------------------------------------- + ! 4.2 Cloud check: step 1 + ! Emissivity at Tropopause Test (ETROP) + !-------------------------------------------------------------------------- + if ( all((/rad_O14,rad_M14,rad_tropt/) > 0.0) ) & + crit_clddet = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) + + case (3) + !-------------------------------------------------------------------------- + ! 4.3 Cloud check: step 2 + ! Positive Fourteen Minus Fifteen Test (PFMFT) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = & + tb_xb_clr(ch14,n) > 0.0 .and. & + tb_xb_clr(ch15,n) > 0.0 .and. & + (tb_xb_clr(ch14,n) >= tb_xb_clr(ch15,n)) + + if ( (tb_obs(ch14,n)) <= 310. .and. & + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) >= 0.3 .and. & + tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) & + crit_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) +! above using ob without VarBC +! ------------------------------- +! crit_clddet = (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) ) +! above using ob with VarBC (requires clear-sky tb_inv) +! ------------------------------- + + if ( crit_clddet > missing_r .and. & + (tb_obs(ch14,n)) > 270. .and. & + tb_xb_clr(ch14,n) > 270. ) & + crit_clddet = crit_clddet - & + (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n)) * & + (tb_obs(ch14,n) - 260.) / (tb_xb_clr(ch14,n) - 260.) +! above 1 line using ob without VarBC +! (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - 260.)/ & +! (tb_xb_clr(ch14,n) - 260.) +! above 2 lines using ob with VarBC (requires clear-sky tb_inv) + + case (4) + !-------------------------------------------------------------------------- + ! 4.4 Negative Fourteen Minus Fifteen Test (NFMFT) + !-------------------------------------------------------------------------- + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. .and. & + tb_xb_clr(ch14,n) > 0. .and. tb_xb_clr(ch15,n) > 0. ) & + crit_clddet = (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n) ) & + - (tb_obs(ch14,n) - tb_obs(ch15,n)) + + case (5) + !-------------------------------------------------------------------------- + ! 4.5 Relative Fourteen Minus Fifteen Test (RFMFT) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) then + qual_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) < 1.0 + qual_clddet(2) = qual_clddet(2) .and. tb_obs(ch14,n) <= 300. + qual_clddet(3:4) = .false. + + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RFMFT + end if + + case (6) + !-------------------------------------------------------------------------- + ! 4.6 Cirrus Water Vapor Test (CIRH2O) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = & + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%terr_hgt <= 2000. & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch10) > 0.5 & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) > 0.5 + + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O + + case (7) + !-------------------------------------------------------------------------- + ! 4.7 Modified 4um Emissivity Test (M-4EMISS) + !-------------------------------------------------------------------------- + ! Modify EMISS for sun glint area may be not work, because we are at north land + ! - compute relative azimuth + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & + crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14) / & + (rad_b_ch7 / rad_b_ch14) + + if ( iv%instid(isens)%solzen(n) > 0. & + .and. iv%instid(isens)%solzen(n) < 90. ) then + Relaz = RELATIVE_AZIMUTH(iv%instid(isens)%solazi(n),iv%instid(isens)%satazi(n)) + + ! - compute glint angle + Glintzen = GLINT_ANGLE(iv%instid(isens)%solzen(n),iv%instid(isens)%satzen(n),Relaz ) + + if ( Glintzen < 40.0 .and. isflg==sea_flag) then + if (tb_xb_clr(ch7,n) > 0. .and. tb_obs(ch7,n) > 0.) then + crit_clddet = tb_xb_clr(ch7,n) - tb_obs(ch7,n) ! (B_ch7 - O_ch7) + else + crit_clddet = missing_r + endif + offset_clddet = 1 + end if + end if + + case (8) + !-------------------------------------------------------------------------- + ! 4.8 Uniform low stratus Test (ULST) + !-------------------------------------------------------------------------- +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test + qual_clddet = iv%instid(isens)%solzen(n) >= 85.0 + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & + crit_clddet = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 + + case (9) + !-------------------------------------------------------------------------- + ! 4.9 New Optically Thin Cloud Test (N-OTC) + !-------------------------------------------------------------------------- +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test + if ( iv%instid(isens)%solzen(n) >= 85.0 ) & + offset_clddet = 1 ! night time + + if (tb_obs(ch7,n) > 0. .and. tb_obs(ch15,n) > 0.) & +! using ob without VarBC +! ------------------------------- + crit_clddet = tb_obs(ch7,n) - tb_obs(ch15,n) + +! using ob with VarBC (requires clear-sky tb_inv) +! ------------------------------- +! crit_clddet = tb_inv(ch7,n) + tb_xb_clr(ch7,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) + + case (10) + !-------------------------------------------------------------------------- + ! 4.10 Temporal Infrared Test (TEMPIR) + !-------------------------------------------------------------------------- + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%TEMPIR + + case default + cycle ABICloudTestLoop + end select + +! call evaluate_clddet_test ( & +! isflg, isflgs_clddet, crit_clddet, eps_clddet(index_clddet(itest)+offset_clddet,:), qual_clddet, & +! iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & +! reject_clddet ) + + reject_clddet = crit_clddet > missing_r .and. & + any( isflg.eq.isflgs_clddet .and. & + crit_clddet > eps_clddet(index_clddet(itest)+offset_clddet,:) .and. & + qual_clddet ) + + if (reject_clddet) then + if (iv%instid(isens)%info%proc_domain(1,n)) then + nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 +!JJGDEBUG + if (print_cld_debug) write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n) +!JJGDEBUG + end if + + clddet_tests(isuper, jsuper, itest) = 1 + end if + end do ABICloudTestLoop + end do ! isuper + end do ! jsuper + if ( iv%instid(isens)%superob_width > 1 ) then + iv%instid(isens)%cloud_frac(n) = & + real( count(sum(clddet_tests,3) > 0), 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) + end if + + ! cloud_flag = - round (mean number of tests failed) + iv%instid(isens)%cloud_flag(:,n) = & + - NINT( real( sum(clddet_tests) , 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) ) + + if (.not. crtm_cloud .and. & + iv%instid(isens)%cloud_flag(1,n) < 0) then + tb_qc = qc_bad + end if + +!JJGDEBUG + if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests(superob_center,superob_center,:) +!JJGDEBUG + end if abi_clddet + + tb_obs => ob%instid(isens)%tb + + ! --------------------------- + ! 5.0 assigning obs errors + if (.not. crtm_cloud ) then + if (use_error_factor_rad) then + iv%instid(isens)%tb_error(:,n) = & + satinfo(isens)%error_std(:) * satinfo(isens)%error_factor(:) + else + iv%instid(isens)%tb_error(:,n) = satinfo(isens)%error_std(:) + end if + else !crtm_cloud + ! calculate cloud impacts + where ( tb_inv( :, n ) > missing_r & + .and. tb_obs( :, n ) > 0. & + .and. tb_xb( :, n ) > 0. & + .and. BTlim( : ) > 0. & !Harnisch + ) +! .and. tb_xb_clr( :, n ) > 0. & !Okamoto or Guerrette + +! using ob with VarBC (tb_inv + tb_xb) +! ------------------------------- +!! Harnisch et al. (2016) + cloud_mod(:,n) = max( 0., BTlim(:) - tb_xb(:,n) ) + cloud_obs(:,n) = max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) + +!! Okamoto et al. (2013) +! cloud_mod(:,n) = abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & +! cloud_obs(:,n) = abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) +!!! J. Guerrette +! cloud_mod(:,n) = max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & +! cloud_obs(:,n) = max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) + endwhere +!JJGDEBUG + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F16.8))') 'PIXEL_DEBUG93: ', n, & + 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) +!JJGDEBUG + + if (abi_use_symm_obs_err) then + ! symmetric error model + ! - Okamoto, McNally, & Bell (2013) + ! - Harnish, Weissmann, & Perianez (2016) + + cloud_mean = 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) + + do k = 1, nchan + if ( cloud_mean(k) > missing_r ) then + if ( cloud_mean(k) < camin ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + else if ( cloud_mean(k) < satinfo(isens)%error_cld_x(k) ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & + ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & + ( cloud_mean(k) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) + else + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) + end if + else + iv%instid(isens)%tb_error(k,n) = missing_r + end if + end do ! nchan + else + iv%instid(isens)%tb_error(1:nchan,n) = satinfo(isens)%error_std(1:nchan) + end if + end if + + ! 5.1 check obs and background + !----------------------------------------------------------------- + do k = 1, nchan + if (tb_obs(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + if (tb_xb(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + end do ! nchan + + + ! 5.2 check innovation + !----------------------------------------------------------------- + ! absolute departure check + do k = 1, nchan + if (abs(tb_inv(k,n)) > inv_grosscheck) then + tb_qc(k) = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + end if + end do ! nchan + + iv%instid(isens)%tb_qc(:,n) = tb_qc + + do k = 1, nchan + ! relative departure check + if (abs(tb_inv(k,n)) > 3.0 * iv%instid(isens)%tb_error(k,n)) then + iv%instid(isens)%tb_qc(k,n) = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_omb_std(k) = nrej_omb_std(k) + 1 + end if + + ! final QC decsion + if (iv%instid(isens)%tb_qc(k,n) == qc_bad) then +! iv%instid(isens)%tb_error(k,n) = 500.0 + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej(k) = nrej(k) + 1 + else + if (iv%instid(isens)%info%proc_domain(1,n)) & + ngood(k) = ngood(k) + 1 + end if + end do ! nchan + end do ABIPixelQCLoop + + ! Do inter-processor communication to gather statistics. + call da_proc_sum_int (num_proc_domain) + call da_proc_sum_int (nrej_mixsurface) + call da_proc_sum_int (nrej_land) + call da_proc_sum_ints (nrej_eccloud) + + do itest = 1, num_clddet_tests + call da_proc_sum_ints (nrej_clddet(:,itest)) + end do + + call da_proc_sum_ints (nrej_omb_abs) + call da_proc_sum_ints (nrej_omb_std) + call da_proc_sum_ints (nrej_clw) + call da_proc_sum_ints (nrej) + call da_proc_sum_ints (ngood) + + if (rootproc) then + if (num_fgat_time > 1) then + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string)//'_',iv%time + else + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string) + end if + + call da_get_unit(fgat_rad_unit) + open(fgat_rad_unit,file=trim(filename),form='formatted',iostat=ios) + if (ios /= 0) then + write(unit=message(1),fmt='(A,A)') 'error opening the output file ', filename + call da_error(__FILE__,__LINE__,message(1:1)) + end if + + write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(isens)%rttovid_string + if(num_proc_domain > 0) write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain + write(fgat_rad_unit,'(a20,i7)') ' nrej_mixsurface = ', nrej_mixsurface + write(fgat_rad_unit,'(a20,i7)') ' nrej_land = ', nrej_land + write(fgat_rad_unit,'(a20)') ' nrej_eccloud(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_eccloud(:) + write(fgat_rad_unit,'(a20)') ' nrej_clw(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_clw(:) + + do itest = 1, num_clddet_tests + write(fgat_rad_unit,'(3A)') ' nrej_',trim(crit_names_clddet(itest)),'(:) = ' + write(fgat_rad_unit,'(10i8)') nrej_clddet(:,itest) + end do + + write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_abs(:) + write(fgat_rad_unit,'(a20)') ' nrej_omb_std(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_std(:) + write(fgat_rad_unit,'(a20)') ' nrej(:) = ' + write(fgat_rad_unit,'(10i7)') nrej(:) + write(fgat_rad_unit,'(a20)') ' ngood(:) = ' + write(fgat_rad_unit,'(10i7)') ngood(:) + + close(fgat_rad_unit) + call da_free_unit(fgat_rad_unit) + end if + + if (trace_use) call da_trace_exit("da_qc_goesabi") + +end subroutine da_qc_goesabi + diff --git a/var/da/da_radiance/da_qc_rad.inc b/var/da/da_radiance/da_qc_rad.inc index 6a418fbbb8..2d320227ab 100644 --- a/var/da/da_radiance/da_qc_rad.inc +++ b/var/da/da_radiance/da_qc_rad.inc @@ -14,7 +14,7 @@ subroutine da_qc_rad (it, ob, iv) integer :: i, nchan,p,j logical :: amsua, amsub, hirs, msu,airs, hsb, ssmis, mhs, iasi, seviri - logical :: mwts, mwhs, atms, amsr2, imager, ahi, mwhs2, gmi + logical :: mwts, mwhs, atms, amsr2, imager, ahi, mwhs2, gmi, abi integer, allocatable :: index(:) integer :: num_tovs_avg @@ -66,6 +66,7 @@ subroutine da_qc_rad (it, ob, iv) amsr2 = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsr2' imager = trim(rttov_inst_name(rtminit_sensor(i))) == 'imager' ahi = trim(rttov_inst_name(rtminit_sensor(i))) == 'ahi' + abi = trim(rttov_inst_name(rtminit_sensor(i))) == 'abi' gmi = trim(rttov_inst_name(rtminit_sensor(i))) == 'gmi' if (hirs) then ! 1.0 QC for HIRS @@ -104,6 +105,8 @@ subroutine da_qc_rad (it, ob, iv) call da_qc_ahi(it,i,nchan,ob,iv) else if (imager) then call da_qc_goesimg(it,i,nchan,ob,iv) + else if (abi) then + call da_qc_goesabi(it,i,nchan,ob,iv) else if (gmi) then call da_qc_gmi(it,i,nchan,ob,iv) else diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 167d0480b5..cb1aa20d6b 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -11,6 +11,9 @@ module da_radiance #if defined(RTTOV) || defined(CRTM) use module_domain, only : xb_type, domain +#ifdef DM_PARALLEL + use module_dm, only : ntasks_x, ntasks_y +#endif use module_radiance, only : satinfo, & i_kind,r_kind, r_double, & one, zero, three,deg2rad,rad2deg, & @@ -58,6 +61,8 @@ module da_radiance use_rad,crtm_cloud, DT_cloud_model, global, use_varbc, freeze_varbc, & airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & + use_goesabiobs, abi_superob_halfwidth, & + var4d, var4d_bin, & use_goesimgobs, pi, earth_radius, satellite_height,use_clddet_zz, ahi_superob_halfwidth, ahi_apply_clrsky_bias #ifdef CRTM @@ -88,7 +93,7 @@ module da_radiance use da_statistics, only : da_stats_calculate use da_tools, only : da_residual, da_obs_sfc_correction, & da_llxy, da_llxy_new, da_togrid_new, da_get_julian_time, da_get_time_slots, & - da_xyll, map_info + da_xyll, map_info, da_llxy_1d use da_tracing, only : da_trace_entry, da_trace_exit, da_trace, & da_trace_int_sort use da_varbc, only : da_varbc_direct,da_varbc_coldstart,da_varbc_precond, & @@ -129,6 +134,11 @@ module da_radiance #include "da_read_obs_netcdf4ahi_geocat.inc" #include "da_read_obs_netcdf4ahi_jaxa.inc" #include "da_read_obs_ncgoesimg.inc" +#include "da_read_obs_ncgoesabi.inc" +#include "da_get_sat_angles.inc" +#include "da_get_sat_angles_1d.inc" +#include "da_get_solar_angles.inc" +#include "da_get_solar_angles_1d.inc" #include "da_read_obs_hdf5gmi.inc" #include "da_get_satzen.inc" #include "da_allocate_rad_iv.inc" diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index e4690c086b..d53688d6a5 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -9,9 +9,11 @@ module da_radiance1 #ifdef CRTM use module_radiance, only : CRTM_Planck_Radiance, CRTM_Planck_Temperature #endif + use module_radiance, only : & #ifdef RTTOV - use module_radiance, only : coefs + coefs, & #endif + deg2rad use da_control, only : trace_use,missing_r, rootproc, & stdout,myproc,qc_good,num_fgat_time,qc_bad, & @@ -22,12 +24,16 @@ module da_radiance1 use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet, use_satcv, cv_size_domain, & cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg,use_clddet_zz, & - ahi_superob_halfwidth, ahi_use_symm_obs_err + ahi_superob_halfwidth, abi_superob_halfwidth, ahi_use_symm_obs_err, abi_use_symm_obs_err use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, clddet_geoir_type, superob_type use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer - use da_par_util, only : da_proc_stats_combine +#ifdef DM_PARALLEL + use da_par_util, only : da_proc_stats_combine, true_mpi_real +#else + use da_par_util, only : da_proc_stats_combine +#endif use da_par_util1, only : da_proc_sum_int,da_proc_sum_ints use da_reporting, only : da_error, message use da_statistics, only : da_stats_calculate @@ -48,7 +54,7 @@ module da_radiance1 #endif implicit none - + type datalink_type type (info_type) :: info @@ -75,6 +81,7 @@ module da_radiance1 real, pointer :: tb_inv(:) real, pointer :: tb_qc(:) real, pointer :: tb_error(:) + real, pointer :: rad_obs(:) integer :: sensor_index type (datalink_type), pointer :: next ! pointer to next data end type datalink_type @@ -248,6 +255,7 @@ module da_radiance1 #include "da_qc_ahi.inc" #include "da_qc_gmi.inc" #include "da_qc_goesimg.inc" +#include "da_qc_goesabi.inc" #include "da_write_iv_rad_ascii.inc" #include "da_write_iv_rad_for_multi_inc.inc" #include "da_read_iv_rad_for_multi_inc.inc" diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 3773b40122..63e471de9c 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -34,8 +34,9 @@ subroutine da_radiance_init(iv,ob) integer :: iunit character(len=filename_len) :: filename character(len=20) :: cdum + real :: error_cld_y, error_cld_x ! for ABI character(len=12) :: cdum12 - real :: error_cld + real :: error_cld ! for AMSR2 ! local variables for tuning error factor !---------------------------------------- @@ -152,6 +153,9 @@ subroutine da_radiance_init(iv,ob) else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'imgr' ) then nchanl(n) = 4 nscan(n) = 60 + else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'abi' ) then + nchanl(n) = 10 + nscan(n) = 22 else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'gmi' ) then nchanl(n) = 13 nscan(n) = 221 @@ -204,6 +208,14 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % clearSkyBias(nchanl(n)) ) endif + ! Allocate additional fields for ABI + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) + allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) + satinfo(n) % error_cld_y(:) = 500.0 !initialize + satinfo(n) % error_cld_x(:) = 5.0 !initialize + endif + read(iunit,*) do j = 1, nchanl(n) read(iunit,'(1x,5i5,2e18.10,a20)') & @@ -217,7 +229,7 @@ subroutine da_radiance_init(iv,ob) cdum !in the current radiance info files, the last column !can be either sensor_id_string or blank - if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then + if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then ! this is for AMSR2 ! read the line again to get error_cld when it is available backspace(iunit) read(iunit,'(1x,5i5,2e18.10,f10.5)') & @@ -228,10 +240,10 @@ subroutine da_radiance_init(iv,ob) idum, & satinfo(n)%error(j), & satinfo(n)%polar(j), & - error_cld - if ( error_cld > 0.0 ) then + error_cld + if ( error_cld > 0.0 ) then satinfo(n)%error_cld(j) = error_cld - end if + end if end if ! If AHI, read some extra things @@ -258,6 +270,30 @@ subroutine da_radiance_init(iv,ob) write(*,fmt='(i7,6x,4f9.3)') satinfo(n)%ichan(j), satinfo(n)%BTLim(j), satinfo(n)%ca1(j), satinfo(n)%ca2(j), satinfo(n)%clearSkyBias(j) endif + ! If ABI, read some extra things + ! Unfortunately, we need to read everything again... + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + backspace(iunit) + read(iunit,'(1x,5i5,2e18.10,2f10.5)') & + wmo_sensor_id, & + satinfo(n)%ichan(j), & + sensor_type, & + satinfo(n)%iuse(j) , & + idum, & + satinfo(n)%error(j), & + satinfo(n)%polar(j), & + error_cld_y, error_cld_x + if ( error_cld_y > 0.0 ) & + satinfo(n)%error_cld_y(j) = error_cld_y + if ( error_cld_x > 0.0 ) & + satinfo(n)%error_cld_x(j) = error_cld_x + if ( j == 1 ) then + write(*,*)'Reading extra data for ABI' + write(*,*)'Channel error_cld_y error_cld_x' + endif + write(*,fmt='(i7,6x,2f10.5)') satinfo(n)%ichan(j), satinfo(n)%error_cld_y(j), satinfo(n)%error_cld_x(j) + endif + iv%instid(n)%ichan(j) = satinfo(n)%ichan(j) ob%instid(n)%ichan(j) = satinfo(n)%ichan(j) end do diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc new file mode 100644 index 0000000000..30ba8f994b --- /dev/null +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -0,0 +1,2623 @@ +subroutine da_read_obs_ncgoesabi (iv, satellite_id) + + implicit none + +! 1.0 Read locs, parse, and select NC files: identify files for channels, views, times, overlap w/ patch/domain +!---------------------------------------------------------------------------------------------------------- +! 2.0 Read (BT) NC files: grab radiance data and convert to BT (K) +!---------------------------------------------------------------------------------------------------------- +! +! JJG: NEED TO ADD A MORE COMPLETE DESCRIPTION HERE +! + + !These libraries must be linked: netcdf, mpi + + !!These externally defined variables/routines are used herein: + ! cpp: DM_PARALLEL + ! PARALLELIZATION: ntasks_x, ntasks_y, num_procs, myproc, comm, ierr, true_mpi_real + ! RADIANCE OPERATOR: rtminit_nsensor, rtminit_platform, rtminit_sensor, rtminit_satid + ! THINNING: thinning_grid + ! GENERAL OBS: num_fgat_time, time_slots + ! WRFDA types: iv_type, datalink_type, info_type, model_loc_type + ! WRFDA subs: da_llxy, da_get_julian_time, + ! da_get_unit, da_free_unit, + ! da_get_sat_angles(_1d), da_get_solar_angles(_1d) + ! da_trace_entry, da_trace_exit, + ! precisions: r_double, i_kind + + type (iv_type),intent (inout) :: iv + integer, intent(in) :: satellite_id ! 16 or 17 + + type(datalink_type), pointer :: head, p, current, prev, p_fgat + type(info_type) :: info + type(model_loc_type) :: loc + integer(i_kind), allocatable :: ptotal(:) + integer(i_kind) :: nthinned + real(r_double) :: crit + integer(i_kind) :: iout, iobs, i_dummy(1) + logical :: outside, outside_all, iuse, first_chan + logical :: found, head_found + + !! ABI Fixed Grid Variables + integer :: ny_global, nx_global + integer :: yoff_fd, xoff_fd + ! For MPI parallelization + integer :: nbuf, nrad_local, nrad_mask, buf_i, buf_f + integer, allocatable :: nbufs(:), displs(:) + integer :: ny_local, nx_local + + !! Earth location info + real, allocatable :: yy_abi(:), xx_abi(:) + real, allocatable :: yy_1d(:), xx_1d(:) + real, allocatable :: iy_1d(:), ix_1d(:) + real, allocatable :: solzen_1d(:), solazi_1d(:) + + real(r_double) :: req, rpol, pph, nam +!!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_sat_angles + real, allocatable, target :: buf_real(:,:) + integer, allocatable, target :: buf_int(:,:) + type(model_loc_type), allocatable, target :: buf_loc(:) + type(info_type), allocatable :: info_1d(:) + + + ! Masks for data reduction + logical :: earthmask, zenmask + logical, allocatable :: & + earthmask_1d(:) , & + zenmask_1d(:) , & + domainmask_1d(:) , & + patchmask_1d(:) , & + dummybool_2d(:,:) , & + allmask_p(:,:) , & + readmask_p(:,:) , & + thinmask(:,:) + + logical, allocatable :: view_mask(:,:,:,:,:) + + logical :: use_view_mask, best_view + + + ! Brightness Temperature (K) + real, allocatable :: bt_p(:,:,:), rad_p(:,:,:), terrain_hgt(:,:) + real :: bc1, bc2, fk1, fk2 + + !! Iterates + integer :: ichan, ifile, iview, ifgat, ipass, ioff, & + jchan, jfile, jview, icount, io_stat, & + n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid, & + isup, jsup, ixsup, iysup + INTEGER :: cstat, estat + CHARACTER(LEN=100) :: cmsg + logical :: exists + + !! Satellite variables + integer(i_kind),parameter :: nchan = 10 + integer(i_kind),parameter :: nscan = 22 + integer, parameter :: platform_id = 4 ! GOES series + integer, parameter :: sensor_id = 44 ! ABI + integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels +! integer, parameter :: channel_index(channel_list(1):channel_list(nchan)) = (/1,2,3,4,5,6,7,8,9,10/) !List of all available channels + + integer, parameter :: nviews = 4 + integer(i_kind) :: inst + character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' + + !! File reading variables + character(len=1000) :: fname, command + character(len=50) :: list_file + integer :: file_unit + + type date_type + integer :: yr, mt, dy, hr, mn, sc, jdy + real(r_double) :: obs_time + end type date_type + +! ! Linked list type for radiance location information +! type viewnode +! real :: lat, lon, satzen, satazi +! integer :: iy, ix +! type(model_loc_type) :: loc +! type(viewnode), pointer :: next +! integer :: i +! end type viewnode + + type field_r + real, pointer :: local(:) + real, pointer :: domain(:) + real, pointer :: patch(:) + end type field_r + type field_i + integer, pointer :: local(:) + integer, pointer :: domain(:) + integer, pointer :: patch(:) + end type field_i + type field_loc + type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: domain(:) + type(model_loc_type), pointer :: patch(:) + end type field_loc + + type viewinfo + logical :: select + integer :: nfiles + character(len=1000) :: fpath + character(len=200), allocatable :: filename(:) + integer, allocatable :: filechan(:) + type(date_type), allocatable :: filedate(:) + logical, allocatable :: file_fgat_match(:,:) + real*8, allocatable :: fgat_time_abs_diff(:,:) ! seconds + real*8, allocatable :: min_time_diff(:,:) ! seconds + integer, allocatable :: nfiles_used(:) + logical :: meta_initialized = .false. + logical :: grid_initialized = .false. + integer :: ny_global, nx_global, yoff_fd, xoff_fd + integer :: ys_local, xs_local + integer :: ye_local, xe_local + integer, allocatable :: ny_grid(:), nx_grid(:) + integer, allocatable :: ys_grid(:), xs_grid(:) + integer :: ys_p, xs_p + integer :: ye_p, xe_p + integer :: ys_p_fd, xs_p_fd + integer :: ye_p_fd, xe_p_fd + integer :: nrad_on_patch, nrad_on_domain + integer :: nrad_on_patch_cldqc, nrad_on_domain_cldqc + logical, allocatable :: patchmask(:,:,:) +! type(viewnode), pointer :: head +! type(viewnode), pointer :: current + + type(field_r) :: lat_1d, lon_1d, satzen_1d, satazi_1d + type(field_i) :: iy_1d, ix_1d + type(field_loc) :: loc_1d + + character(len=2) :: name_short + character(len=10) :: name + logical :: moving + end type viewinfo + + type(viewinfo), target, allocatable :: view_att(:) + type(viewinfo), pointer :: this_view + + integer :: first_file, tot_files_used, npass + integer :: ncid, varid + + !! WRFDA channel and satellite_id select + !! These should be inputs to the subroutine or global variables in WRFDA + !Could populate using .info file. Would reduce number of files to read... +! integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) + + ! Global WRFDA obs timing info + character(len=19) :: fgat_times_c(num_fgat_time) + real(r_double) :: fgat_times_r(num_fgat_time) + + ! Local Obs date/time variables + real(r_double) :: obs_time + integer(i_kind) :: yr, mt, dy, hr, mn, sc, jdy + real(r_double) :: timbdy(2) + + ! Other work variables + real(r_double) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg + real(r_double) :: ngoes + integer(i_kind) :: num_goesabi_local, num_goesabi_global, & + num_goesabi_used, num_goesabi_used_fgat(num_fgat_time), & + num_goesabi_used_tmp, num_goesabi_thinned + integer(i_kind) :: itx, itt + real, allocatable :: in(:), out(:) + + !Cloud QC variables + integer :: tbuf, nkeep, ikeep + integer :: abi_halo_width ! Must be ≥ 0 + integer :: superob_width + real :: mu10, mu14, sigma10, sigma14, pearson, temp_max + real :: mu, sigma + real, allocatable :: tb_temp(:,:) + logical :: cldqc + character(18) :: terr_fname + + integer :: TEMPIR_ifile + real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff + real, parameter :: TEMPIR_delay_minutes = 15.0 + + if (trace_use) call da_trace_entry("da_read_obs_ncgoesabi") + +! determine if satellite_id is supported +!----------------------------------------------------- + if(satellite_id .ne. 16 .and. & + satellite_id .ne. 17) then + write(unit=stdout,fmt='(A,I2.2,A)') 'goes satellite ', satellite_id, ' is not supported for abi instrument' + return + endif + + write(terr_fname,'(A,I2.2,A)') 'OR_ABI-TERR_G',satellite_id,'.nc' + +! determine if sensor triplet is in the sensor list +!----------------------------------------------------- + inst = 0 + do ngoes = 1, rtminit_nsensor + if (platform_id == rtminit_platform(ngoes) & + .and. sensor_id == rtminit_sensor(ngoes) & + .and. satellite_id == rtminit_satid(ngoes)) then + inst = ngoes + else + cycle + end if + end do + if (inst == 0) then + write(unit=message(1),fmt='(A,I2.2,A)') " goes-",satellite_id,"-abi is not in sensor list" + call da_warning(__FILE__,__LINE__, message(1:1)) + return + end if + + allocate(ptotal(0:num_fgat_time)) + ptotal(0:num_fgat_time) = 0 + iobs = 0 ! for thinning, argument is inout + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Initialize ABI L1B reading + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifgat=1,num_fgat_time + if (num_fgat_time.eq.1 .or. (ifgat.gt.1 .and. ifgat.lt.num_fgat_time)) then + fgat_times_r(ifgat) = & + (time_slots(ifgat) + time_slots(ifgat-1)) / 2.D0 !minutes + else if (ifgat .eq. 1) then !First time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat-1) !minutes + else !Last time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat) !minutes + end if + + call da_get_cal_time(fgat_times_r(ifgat),yr,mt,dy,hr,mn,sc) + fgat_times_r(ifgat) = fgat_times_r(ifgat) * 60.D0 !seconds + + write(unit=fgat_times_c(ifgat), & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + end do + + allocate(view_att(nviews)) + ! (default) All views are used (algorithm figures out which views have files present) + ! Could set this according to namelist entries + view_att(:) % select = .true. + view_att(1) % name_short = 'F' + view_att(2) % name_short = 'C' + view_att(3) % name_short = 'M1' + view_att(4) % name_short = 'M2' + + view_att(1) % name = 'Full Disk' + view_att(2) % name = 'CONUS' + view_att(3) % name = 'MESO1' + view_att(4) % name = 'MESO2' + + write(view_att(1) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-fdisk*/" + write(view_att(2) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-conus*/" + write(view_att(3) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" + write(view_att(4) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" + + ! (default) Full Disk and CONUS are fixed while MESO 1 & 2 can move within an assimilation window + view_att(1) % moving = .false. + view_att(2) % moving = .false. + view_att(3) % moving = .true. + view_att(4) % moving = .true. + +! ! Full Disk, CONUS, and MESO 1 & 2 are fixed within an assimilation window (e.g., 3D-Var) +! view_att(1) % moving = .false. +! view_att(2) % moving = .false. +! view_att(3) % moving = .false. +! view_att(4) % moving = .false. + + !! Initialize local obs structures + allocate (head) + nullify (head % next ) + p => head + + num_goesabi_local = 0 + num_goesabi_global = 0 + num_goesabi_used_fgat = 0 + num_goesabi_thinned = 0 + + abi_halo_width = abi_superob_halfwidth + if ( use_clddet_zz ) then + abi_halo_width = abi_halo_width + 10 + end if + + superob_width = 2*abi_superob_halfwidth+1 + + tot_files_used = 0 + use_view_mask = .false. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Collect files available for all views + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + PrepViews: do iview = 1, nviews + this_view => view_att(iview) + + if ( .not.this_view % select ) cycle PrepViews + + ! Query fpath for files that match L1B naming conventions for this_view and satellite_id + fname = trim(INST_PREFIX)//trim(this_view % name_short) + write(list_file,'(A,I2.2,2A)') & + 'file_list_GOES-',satellite_id,'-ABI_',trim(this_view % name_short) + + call da_get_unit(file_unit) + + if (rootproc) then + inquire(file=trim(list_file), exist=exists) + if ( .not.exists ) then + ! Create list_file containing all files for this_view + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' + + write(command,fmt='(5A,I2.2,2A)')& + "find ",trim(this_view % fpath), & + " \( -type l -o -type f \) -name '",trim(fname), & + "*G",satellite_id, & + "*' > ",trim(list_file) +! "*' -printf '%P\n' > ",trim(list_file) + + write(stdout,fmt='(A)') 'WARNING find requires substantial memory. It is recommended to issue' + write(stdout,fmt='(A)') 'WARNING the following from the command line before running WRFDA:' + write(stdout,fmt='(A)') adjustl(trim(command)) + cmsg = "" + call execute_command_line ( adjustl(trim(command)), & + WAIT=.true., EXITSTAT=estat, CMDSTAT=cstat, CMDMSG=cmsg ) + write(stdout,*) 'estat: ', estat + write(stdout,*) 'cstat: ', cstat + write(stdout,*) 'cmsg: ', cmsg + end if + write(unit=stdout,fmt='(5A)') 'Using GOES ', trim(this_view % name) ,' files listed in ', trim(list_file) + + icount = 0 + io_stat = -1 + do while (io_stat .ne. 0) + open(unit=file_unit,file=trim(list_file), iostat = io_stat) + icount = icount + 1 + if (icount .gt. 10000) exit + end do + + this_view % nfiles = 0 + do + read(file_unit, fmt=*, iostat = io_stat) + if ( io_stat .ne. 0 ) exit + this_view % nfiles = this_view % nfiles + 1 + end do + close(file_unit) + + i_dummy = this_view % nfiles + end if +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) + call mpi_bcast ( i_dummy(1), 1, mpi_integer, root, comm, ierr ) + this_view % nfiles = i_dummy(1) +#endif + if (this_view % nfiles .lt. 1) then + this_view % select = .false. + cycle PrepViews + end if + + allocate(this_view % filename(this_view % nfiles)) + + ! Read the file names for this view + open(unit=file_unit,file=trim(list_file)) + read(file_unit, fmt='(A)') (this_view % filename(ifile), ifile=1,this_view % nfiles) + close(file_unit) + + call da_free_unit(file_unit) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Allocate/init components for this_view + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(this_view % filechan(this_view % nfiles)) + allocate(this_view % filedate(this_view % nfiles)) + allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) + allocate(this_view % fgat_time_abs_diff(this_view % nfiles,num_fgat_time)) + allocate(this_view % min_time_diff(nchan,num_fgat_time)) + allocate(this_view % nfiles_used(num_fgat_time)) + + this_view % file_fgat_match = .false. + do ifgat=1,num_fgat_time + this_view % fgat_time_abs_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds + + this_view % min_time_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which of the files will be used based on user-definitions: + !! + fgat window length + !! + channels used + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifile = 1, this_view % nfiles + + !Grab the filename (without path) using INST_PREFIX + fname = trim(this_view % filename(ifile)) + ioff = index(fname, trim(INST_PREFIX)) +!! this_view % filepath(ifile) = fname(1:ioff-1) + fname = trim(fname(ioff:len(adjustl(trim(fname))))) +!! this_view % filename(ifile) = trim(fname) + + ioff = 0 + if (iview.eq.3 .or. iview.eq.4) ioff=1 + ioff = ioff+19 + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) + +!!! !! The channel could instead be read from band_id in each file, but +!!! !! opening/closing files for all channels is time consuming +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'band_id',varid) +!!! ierr=nf_get_var_int(ncid,varid,this_view % filechan(ifile)) +!!! ierr=nf_close(ncid) + + ! Check if channel is selected +! if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & + if ( .not.any(this_view % filechan(ifile) .eq. channel_list) ) then +!!! ierr=nf_close(ncid) + cycle + end if + + !! Determine central date of this file for obs binning + !obs START time + ioff = ioff + 8 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) + + this_view % filedate(ifile) % jdy = jdy + + !obs END time + ioff = ioff + 16 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = obs_time + real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) + + obs_time = obs_time + (timbdy(1) + timbdy(2)) / 2.D0 + +!! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. +! !! Determine central date of this file for obs binning +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'time_bounds',varid) +!!! ierr=nf_get_var_double(ncid,varid,timbdy) +!!! ierr=nf_close(ncid) +!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 + + call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) + obs_time = obs_time * 60.D0 + + this_view % filedate(ifile) % yr = yr + this_view % filedate(ifile) % mt = mt + this_view % filedate(ifile) % dy = dy + this_view % filedate(ifile) % hr = hr + this_view % filedate(ifile) % mn = mn + this_view % filedate(ifile) % sc = sc + this_view % filedate(ifile) % obs_time = obs_time + + +!JJG: Note that this test being limited by time_slots prevents the use of data before/after the first/last time of the window even if the observations outside the window were recorded at times nearer to those bounds than data contained within the window. + if ( obs_time < time_slots(0) * 60.D0 .or. & + obs_time >= time_slots(num_fgat_time) * 60.D0 ) then + cycle + end if + + do ifgat=1,num_fgat_time + this_view % file_fgat_match(ifile,ifgat) = & + ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & + obs_time < time_slots(ifgat) * 60.D0 ) + if (this_view % file_fgat_match(ifile,ifgat)) exit + end do + + this_view % fgat_time_abs_diff(ifile,ifgat) = & + abs( obs_time - fgat_times_r(ifgat) ) + + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .ge. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + else + this_view % min_time_diff(ichan, ifgat) = this_view % fgat_time_abs_diff(ifile, ifgat) + end if + + if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then + print*, 'WARNING: More than one bin was selected for ',trim(fname) + print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) + print*, 'obs_time = ',obs_time + print*, 'Ignoring this file for reading.' + this_view % file_fgat_match(ifile,:) = .false. + cycle + end if + end do + + do ifgat = 1, num_fgat_time + ! Select a single file for this view, channel, and fgat using min_time_diff + if ( count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .gt. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + end if + end do + end if + end do + end do PrepViews + + !! If Full Disk is selected, take 2 passes over the data: + !! + 1st pass: (A) Determine portions of each view corresponding to this patch + !! for each fgat and each channel across observed domain + !! (B) Eliminate portions of broader views (Full Disk and CONUS) that + !! can be replaced by narrower views (CONUS and MESO) with times + !! closer to fgat time + !! + 2nd pass: read radiance values, convert to BT, calculate quantities for online cloud detection QC + !! + !! Otherwise only take one pass, and duplicated data cannot be removed from CONUS/MESO1/MESO2 + + npass = 1 + if (count(view_att(:) % select).gt.1 .and. view_att(1) % select) npass = 2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Process data for views w/ nfiles > 1 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ipass = 1, npass + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt='(A,I0,A,I2.2,A)') & + 'Starting pass ',ipass,& + ' of GOES-',satellite_id,' ABI data processing' + + !! Loop over the available views for this instrument (ABI) + do iview = 1, nviews + this_view => view_att(iview) + + if ( .not.this_view % select ) cycle + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Access netcdf channel/band files across all fgat windows + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + this_view % nfiles_used = 0 + + fgat_loop: do ifgat = 1, num_fgat_time + if (count(this_view % file_fgat_match(:, ifgat)) .lt. 1) then + cycle fgat_loop + end if + + first_file = 0 + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + first_file = ifile + exit + end do + if (first_file .eq. 0) cycle fgat_loop + + if ( sum(this_view % nfiles_used(:)).eq.0) & + write(unit=stdout,fmt='(2A)') & + 'Processing data for view: ', trim(this_view % name) + write(unit=stdout,fmt='(2A)') & + ' fgat time: ',fgat_times_c(ifgat) + + yr = this_view % filedate(first_file) % yr + mt = this_view % filedate(first_file) % mt + dy = this_view % filedate(first_file) % dy + hr = this_view % filedate(first_file) % hr + mn = this_view % filedate(first_file) % mn + sc = this_view % filedate(first_file) % sc + write(unit=stdout, & + fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + ' data time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + + fname = trim(this_view % filename(first_file)) + + if ( .not.this_view % meta_initialized ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Get ABI metadata (first pass for FD, CONUS, MESO) + ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + write(unit=stdout,fmt='(A)') & + ' Reading abi metadata...' + + this_view % meta_initialized = .true. + + call get_abil1b_metadata( & + fname, this_view % ny_global, this_view % nx_global, & + req, rpol, pph, nam)! , lat_sat, lon_sat ) + +#ifdef DM_PARALLEL + ! Split the global ABI grid for this view into local segments + allocate ( this_view % ny_grid ( num_procs ) ) + allocate ( this_view % nx_grid ( num_procs ) ) + allocate ( this_view % ys_grid ( num_procs ) ) + allocate ( this_view % xs_grid ( num_procs ) ) + + call split_grid( this_view % ny_global, this_view % nx_global , & + this_view % ny_grid, this_view % nx_grid , & + this_view % ys_grid, this_view % xs_grid ) +#else + ! When mpi parallelism is not available, assign global values to local variables + this_view % ny_grid = this_view % ny_global + this_view % nx_grid = this_view % nx_global + this_view % ys_grid = 1 + this_view % xs_grid = 1 +#endif + end if + + ! Recall global dims for this_view + ny_global = this_view % ny_global + nx_global = this_view % nx_global + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Generate grid locations if + !! + CONUS or FD and first matching fgat + !! + MESO and any fgat (extent changes in time) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DoGridGen: if ( this_view % moving .or. .not.this_view % grid_initialized ) then + + ! Read grid from file, convert to lat, lon, satzen, satazi + write(unit=stdout,fmt='(2A)') & + ' Establishing abi grid info...' + + this_view % grid_initialized = .true. + + !======================================================== + ! Establish GOES metadata for this view and ifgat + ! (constant acros fgat's, except for this_view % moving) + !======================================================== + allocate( yy_abi (ny_global) ) + allocate( xx_abi (nx_global) ) + call get_abil1b_grid1( fname, & + ny_global, nx_global, & + yy_abi, xx_abi, & + this_view % yoff_fd, this_view % xoff_fd ) + + if ( iview.eq.1 ) then + yoff_fd = this_view % yoff_fd + xoff_fd = this_view % xoff_fd + this_view % yoff_fd = 1 + this_view % xoff_fd = 1 + else + this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 + this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 + end if + + !=========================================================== + ! Create a local array subset of observation location + ! quantities across processors. + !=========================================================== + nrad_local = ny_global * nx_global / (num_procs-1) + allocate( yy_1d (nrad_local) ) + allocate( xx_1d (nrad_local) ) + allocate( iy_1d (nrad_local) ) + allocate( ix_1d (nrad_local) ) + + n = 0 ; icount = 0 + +!JJG: Not convinced that these subgrids are needed. Might be able to loop over global X/Y instead. This solution may be overly complex. mod test for load balancing is still needed! + ! This loop over subgrids and the selective logic + ! below for myproc balances the processor loads + ! when some imager pixels are off-earth or outside + ! zenith-angle limits (Full Disk and CONUS) + do subgrid = 1, num_procs + ! Recall local dims for this_view + ny_local = this_view % ny_grid(subgrid) + nx_local = this_view % nx_grid(subgrid) + this_view % ys_local = this_view % ys_grid(subgrid) + this_view % xs_local = this_view % xs_grid(subgrid) + + do ixl = 1, nx_local + do iyl = 1, ny_local + iy = iyl + this_view % ys_local - 1 + ix = ixl + this_view % xs_local - 1 + if ( mod( iy-abi_superob_halfwidth-1, superob_width ) == 0 .and. & + mod( ix-abi_superob_halfwidth-1, superob_width ) == 0 ) then + !This mod test produces balanced loads between processors + if ( mod( n, num_procs ) .eq. myproc ) then + icount = icount + 1 + + yy_1d ( icount ) = yy_abi( iy ) + xx_1d ( icount ) = xx_abi( ix ) + iy_1d ( icount ) = iy + ix_1d ( icount ) = ix + end if + n = n + 1 + end if + end do + end do + end do + +! !This may work as a simplified replacement for the code above, not sure if loads will be balanced +! do ix = 1, nx_global +! do iy = 1, ny_global +! !This mod test produces balanced loads between processors +! if ( mod( n, num_procs ) .eq. myproc ) then +! icount = icount + 1 +! yy_1d ( icount ) = yy_abi( iy ) +! xx_1d ( icount ) = xx_abi( ix ) +! iy_1d ( icount ) = iy +! ix_1d ( icount ) = ix +! end if +! n = n + 1 +! end do +! end do + + nrad_local = icount + + deallocate( yy_abi, xx_abi ) + + allocate( earthmask_1d (1:nrad_local) ) + allocate( zenmask_1d (1:nrad_local) ) + allocate( this_view % lat_1d % local (1:nrad_local) ) + allocate( this_view % lon_1d % local (1:nrad_local) ) + allocate( this_view % satzen_1d % local (1:nrad_local) ) + allocate( this_view % satazi_1d % local (1:nrad_local) ) + allocate( this_view % iy_1d % local (1:nrad_local) ) + allocate( this_view % ix_1d % local (1:nrad_local) ) + + ! Assign values for iy, ix, lat, lon, satzen, satazi + this_view % iy_1d % local = iy_1d (1:nrad_local) + this_view % ix_1d % local = ix_1d (1:nrad_local) + deallocate( iy_1d ) + deallocate( ix_1d ) + + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations processed on this core: ', nrad_local + + if (nrad_local .gt. 0) & + call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & + req, rpol, pph, nam, satellite_id, & + this_view % lat_1d % local, & + this_view % lon_1d % local, & + this_view % satzen_1d % local, & + this_view % satazi_1d % local, & + earthmask_1d, zenmask_1d ) + + ! Reduce values for iy, ix, lat, lon, satzen, satazi + ! using earth and zenith masks + nrad_mask = count ( earthmask_1d .and. zenmask_1d ) + this_view % lat_1d % local(1:nrad_mask) = & + pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % lon_1d % local(1:nrad_mask) = & + pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satzen_1d % local(1:nrad_mask) = & + pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satazi_1d % local(1:nrad_mask) = & + pack(this_view % satazi_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % iy_1d % local(1:nrad_mask) = & + pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % ix_1d % local(1:nrad_mask) = & + pack(this_view % ix_1d % local , earthmask_1d .and. zenmask_1d ) + + nrad_local = nrad_mask + + deallocate( earthmask_1d ) + deallocate( zenmask_1d ) + deallocate( yy_1d, xx_1d ) + + ! Populate loc x, y and determine in/outside domain + allocate ( this_view % loc_1d % local (nrad_local) ) + allocate ( domainmask_1d (nrad_local) ) + allocate ( dummybool_2d (nrad_local,2) ) + allocate ( info_1d (nrad_local) ) + info_1d (:) % lat = this_view % lat_1d % local ( 1:nrad_local ) + info_1d (:) % lon = this_view % lon_1d % local ( 1:nrad_local ) + call da_llxy_1d ( info_1d, this_view % loc_1d % local(:), & + dummybool_2d(:,1), dummybool_2d(:,2) ) + domainmask_1d = .not.dummybool_2d(:,2) + deallocate( dummybool_2d ) + deallocate( info_1d ) + nrad_mask = count( domainmask_1d ) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER + ! Note: these comms are a minor bottleneck, which will be + ! more noticeable for 4D-Var when MESO1/2 is processed + ! at multiple fgat's + ! Potential Solutions + ! SOLUTION 1: mpi_allgatherv (let's mpi figure out the most efficient way to distribute the data to all processes) + ! SOLUTION 2: round-robin mpi_bcast (may be less resource intensive with smaller communication chunks) + +! ! BEGIN SOLUTION 1 +!! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +!! this_view % lat_1d % local (1:nrad_mask) = & +!! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % lon_1d % local (1:nrad_mask) = & +!! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satzen_1d % local (1:nrad_mask) = & +!! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satazi_1d % local (1:nrad_mask) = & +!! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % iy_1d % local (1:nrad_mask) = & +!! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % ix_1d % local (1:nrad_mask) = & +!! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % y = & +!! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % x = & +!! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +! !ALLOCATE COMMUNICATION BUFFERS +! allocate ( nbufs ( num_procs ) ) +! allocate ( displs ( num_procs ) ) +!#ifdef DM_PARALLEL +! call mpi_allgather ( nrad_mask, 1, mpi_integer, nbufs, 1, mpi_integer, comm, ierr ) +!#else +! nbufs = nrad_mask +!#endif +! +! displs = 0 +! do iproc = 1, num_procs - 1 +! displs(iproc+1) = displs(iproc) + nbufs(iproc) +! end do +! +! this_view % nrad_on_domain = sum( nbufs ) +! +! allocate( buf_real( this_view % nrad_on_domain, 4 ) ) +! allocate( buf_int ( this_view % nrad_on_domain, 2 ) ) +! allocate( buf_loc ( this_view % nrad_on_domain ) ) +! +! buf_real = missing_r +! buf_int = missing +! buf_loc%y = missing_r +! buf_loc%x = missing_r +! +! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +! buf_i = displs(iproc+1) + 1 +! buf_f = buf_i + nrad_mask - 1 +! buf_real( buf_i:buf_f, 1 ) = & +! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 2 ) = & +! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 3 ) = & +! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 4 ) = & +! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 1 ) = & +! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 2 ) = & +! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % y = & +! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % x = & +! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +!#ifdef DM_PARALLEL +! !PERFORM COMMS +! +! ! NOTE: MPI_IN_PLACE can only be used when comm is an intracommunicator +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +! +!! call mpi_allgatherv ( & +!! this_view % lat_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % lon_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % satzen_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % satazi_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % iy_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % ix_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % y, nrad_mask, true_mpi_real, & +!! buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % x, nrad_mask, true_mpi_real, & +!! buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +!!#else +!! buf_real( :, 1 ) = this_view % lat_1d % local (1:nrad_mask) +!! buf_real( :, 2 ) = this_view % lon_1d % local (1:nrad_mask) +!! buf_real( :, 3 ) = this_view % satzen_1d % local (1:nrad_mask) +!! buf_real( :, 4 ) = this_view % satazi_1d % local (1:nrad_mask) +!! buf_int ( :, 1 ) = this_view % iy_1d % local (1:nrad_mask) +!! buf_int ( :, 2 ) = this_view % ix_1d % local (1:nrad_mask) +!! buf_loc ( : ) % y = this_view % loc_1d % local (1:nrad_mask) % y +!! buf_loc ( : ) % x = this_view % loc_1d % local (1:nrad_mask) % x +!#endif +! deallocate ( nbufs, displs ) +! ! END SOLUTION 1 + + ! BEGIN SOLUTION 2 + !ALLOCATE COMMUNICATION BUFFERS +#ifdef DM_PARALLEL + call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nbuf = nrad_mask +#endif + allocate( buf_real( nbuf, 4 ) ) + allocate( buf_int ( nbuf, 2 ) ) + allocate( buf_loc ( nbuf ) ) + + this_view % nrad_on_domain = nbuf + + buf_f = 0 + ProcLoop: do iproc = 0, num_procs-1 + nbuf = nrad_mask +#ifdef DM_PARALLEL + call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) +#endif + if (nbuf .eq. 0) cycle ProcLoop + buf_i = buf_f + 1 + buf_f = buf_i + nbuf - 1 + + if (iproc .eq. myproc) then + !PACK UP DATA FROM THIS PROCESSOR + buf_real( buf_i:buf_f, 1 ) = & + pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 2 ) = & + pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 3 ) = & + pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 4 ) = & + pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 1 ) = & + pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 2 ) = & + pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) + + buf_loc ( buf_i:buf_f ) % y = & + pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) + buf_loc ( buf_i:buf_f ) % x = & + pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) + else + buf_real(buf_i:buf_f,:) = missing_r + buf_int(buf_i:buf_f,:) = missing +! buf_loc(buf_i:buf_f)%y = missing_r +! buf_loc(buf_i:buf_f)%x = missing_r + end if +#ifdef DM_PARALLEL + !PERFORM COMMS + call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 4, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) + + !Only x & y components of loc need to be communicated + call mpi_bcast( buf_loc(buf_i:buf_f)%y, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f)%x, nbuf, true_mpi_real, iproc, comm, ierr ) +#endif + end do ProcLoop + ! END SOLUTION 2 + + deallocate ( this_view % lat_1d % local ) + deallocate ( this_view % lon_1d % local ) + deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % satazi_1d % local ) + deallocate ( this_view % iy_1d % local ) + deallocate ( this_view % ix_1d % local ) + deallocate ( this_view % loc_1d % local ) + deallocate ( domainmask_1d ) + + ! ASSOCIATE REMOTE POINTERS WITH BUFFERS CONTAINING DOMAIN-WIDE OBS + this_view % lat_1d % domain => buf_real(:,1) + this_view % lon_1d % domain => buf_real(:,2) + this_view % satzen_1d % domain => buf_real(:,3) + this_view % satazi_1d % domain => buf_real(:,4) + this_view % iy_1d % domain => buf_int (:,1) + this_view % ix_1d % domain => buf_int (:,2) + this_view % loc_1d % domain => buf_loc (:) + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within domain: ', this_view % nrad_on_domain + + ! Populate remainder of loc and determine in/outside patch + allocate ( patchmask_1d (this_view % nrad_on_domain) ) + allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) + call da_llxy_1d ( locs = buf_loc, outside = dummybool_2d(:,1), do_xy = .false. ) + patchmask_1d = .not.dummybool_2d(:,1) + deallocate( dummybool_2d ) + this_view % nrad_on_patch = count(patchmask_1d) + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within this subdomain: ', this_view % nrad_on_patch + + if ( this_view % nrad_on_patch .gt. 0 ) then + if ( allocated ( this_view % patchmask ) ) then + deallocate ( this_view % patchmask ) + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) + end if + allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satazi_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) + + this_view % lat_1d % patch = & + pack( this_view % lat_1d % domain, patchmask_1d ) + this_view % lon_1d % patch = & + pack( this_view % lon_1d % domain, patchmask_1d ) + this_view % satzen_1d % patch = & + pack( this_view % satzen_1d % domain, patchmask_1d ) + this_view % satazi_1d % patch = & + pack( this_view % satazi_1d % domain, patchmask_1d ) + this_view % iy_1d % patch = & + pack( this_view % iy_1d % domain, patchmask_1d ) + this_view % ix_1d % patch = & + pack( this_view % ix_1d % domain, patchmask_1d ) + this_view % loc_1d % patch = & + pack( this_view % loc_1d % domain, patchmask_1d ) + + ! Determine grid extents for this patch on this_view and on Full Disk + this_view % ys_p = minval(this_view % iy_1d % patch) + this_view % ye_p = maxval(this_view % iy_1d % patch) + this_view % xs_p = minval(this_view % ix_1d % patch) + this_view % xe_p = maxval(this_view % ix_1d % patch) + this_view % ys_p_fd = this_view % ys_p + this_view % yoff_fd - 1 + this_view % ye_p_fd = this_view % ye_p + this_view % yoff_fd - 1 + this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 + this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 + +! write(stdout,*) 'ABI grid extents for this view:' +! write(stdout,'(A,4I10)') 'ys_p, ye_p, xs_p, xe_p ',this_view % ys_p, this_view % ye_p, this_view % xs_p, this_view % xe_p +! write(stdout,*) 'ABI grid extents for Full Disk:' +! write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd + + ! Setup ZZ clddet extents + this_view % ys_local = max(this_view % ys_p - abi_halo_width, 1) + this_view % ye_local = min(this_view % ye_p + abi_halo_width, ny_global) + this_view % xs_local = max(this_view % xs_p - abi_halo_width, 1) + this_view % xe_local = min(this_view % xe_p + abi_halo_width, nx_global) + + ! Setup patch mask for this view, including ZZ clddet buffer + allocate( this_view % patchmask( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + + this_view % patchmask = .false. + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + + cldqc = .true. + do jy = iy - abi_halo_width, iy + abi_halo_width + do jx = ix - abi_halo_width, ix + abi_halo_width + if ( & + jy.ge.1 .and. jy.le.ny_global & + .and. jx.ge.1 .and. jx.le.nx_global & + ) then + this_view % patchmask ( jy, jx, 2 ) = .true. + else + cldqc = .false. + end if + end do + end do + this_view % patchmask ( iy, ix, 1 ) = cldqc + end do + this_view % nrad_on_patch_cldqc = count( this_view % patchmask (:,:,1) ) + else + this_view % nrad_on_patch_cldqc = 0 + end if +! write(unit=stdout,fmt='(3A,I0)') & +! ' ',trim(this_view % name),' locations within this subdomain eligible for ZZ clddet: ', this_view % nrad_on_patch_cldqc + + + !FREE UP POINTERS AND BUFFERS + nullify ( this_view % lat_1d % domain ) + nullify ( this_view % lon_1d % domain ) + nullify ( this_view % satzen_1d % domain ) + nullify ( this_view % satazi_1d % domain ) + nullify ( this_view % iy_1d % domain ) + nullify ( this_view % ix_1d % domain ) + nullify ( this_view % loc_1d % domain ) + deallocate ( buf_real, buf_int, buf_loc ) + deallocate ( patchmask_1d ) + +#ifdef DM_PARALLEL + call mpi_allreduce( this_view % nrad_on_patch_cldqc, & + this_view % nrad_on_domain_cldqc, & + 1, mpi_integer, mpi_sum, comm, ierr ) + call mpi_barrier(comm, ierr) +#else + this_view % nrad_on_domain_cldqc = this_view % nrad_on_patch_cldqc +#endif + end if DoGridGen + + if ( iview.eq.1 .and. ipass.lt.npass .and. & + sum(this_view % nfiles_used(:)).eq.0 ) then + if ( this_view % nrad_on_patch_cldqc .gt. 0 ) then + allocate( view_mask( & + this_view % ys_p_fd-2:this_view % ye_p_fd+2, & + this_view % xs_p_fd-2:this_view % xe_p_fd+2, & + nviews, nchan, num_fgat_time ) ) + view_mask = .false. + end if + use_view_mask = .true. + end if + +! if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then +! num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc +! !ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc +! end if + + PatchMatch: if (this_view % nrad_on_patch_cldqc .gt. 0) then + + ! Loop over channels; each process reads radiance data only for its subdomain + ChannelLoop: do ichan = 1, nchan + ifile = 0 + do jfile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(jfile,ifgat) ) cycle + call get_ichan(this_view % filechan(jfile), channel_list, nchan, jchan) + if ( ichan .eq. jchan ) then + ifile = jfile + exit + end if + end do + if ( ifile .eq. 0 ) cycle ChannelLoop + + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) + 1 + + VIEW_SELECT: & + if ( ipass.lt.npass .and. use_view_mask ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which view has the closest observed + !! time to fgat for this channel + !! Note: this only needs to be done for a single channel, + !! unless individual channel files are missing at fgat. + !! Solution where file view availability differs by channel used here. + !! (only available when FD data present for one of the fgat times) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( iview.eq.1 ) then + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + view_mask( iyfd, ixfd, iview, ichan, ifgat) = & + this_view % patchmask ( iy, ix, 1 ) + end do + else + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view % min_time_diff(ichan, ifgat) .lt. & + view_att(jview) % min_time_diff(ichan, ifgat) + end do + if ( best_view ) then + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + if ( this_view % patchmask ( iy, ix, 1 ) ) then + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + + view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. + + !This assumes MESO1 and MESO2 do not overlap + view_mask( iyfd, ixfd, 1:min(iview-1,2), ichan, ifgat) = .false. + +! !This assumes MESO1 and MESO2 are in identical locations +! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. + end if + end do + end if + end if + + else + !!Utilizing these masks to eliminate data: + !! + earthmask + !! + zenmask + !! + view_mask [only if npass > 1] + !! + model domain mask + !! + patch mask + !! + thinning + + allocate( allmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + allmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) + + allocate( readmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + readmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) + + ! Only use locations where this view is nearest to this fgat time + ! - only available when FD data present for any fgat time + if ( use_view_mask ) then + if ( .not.any( & + view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & + this_view % xs_p_fd:this_view % xe_p_fd, & + iview, ichan, ifgat ) & + ) ) then + deallocate(allmask_p, readmask_p) + write(unit=stdout,fmt='(3A,I0)') & + ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) - 1 + cycle ChannelLoop + end if + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + + allmask_p( iy, ix ) = & + ( allmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + + readmask_p( iy, ix ) = & + ( readmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + end do + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Read radiance and convert to brightness temp. + !! once per permutation of + !! + INST VIEW (FD, CONUS, MESOx2) + !! + fgat + !! + channel/band + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(unit=stdout,fmt='(A,I0,A,I0)') & + ' Reading ', count(readmask_p), ' abi radiances for band ',channel_list(ichan) + if ( use_clddet_zz) write(unit=stdout,fmt='(A,I0)') & + ' which includes the cloud detection halo' + TEMPIR_ifile = -1 + if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then + ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes + TEMPIR_min_time_diff = TEMPIR_delay_minutes +!write(unit=stdout,fmt='(A,F14.2)') & +! ' ref_time (min): ', this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes + do jfile = 1, this_view % nfiles + if ( this_view % filechan(jfile) .ne. channel_list(ichan) .or. & + jfile .eq. ifile ) cycle + + TEMPIR_time_abs_diff = & + abs( this_view % filedate(jfile) % obs_time / 60.D0 - & + (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) + + if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) then + TEMPIR_ifile = jfile + TEMPIR_min_time_diff = TEMPIR_time_abs_diff + end if + end do + if ( TEMPIR_min_time_diff .gt. 0.5 * TEMPIR_delay_minutes ) then +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is too large - ',TEMPIR_min_time_diff,' minutes' + TEMPIR_ifile = -1 +! else +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is accetable - ',TEMPIR_min_time_diff,' minutes' + end if + end if + + ! Allocate and read bt for this patch and current time + if ( TEMPIR_ifile.gt.0 ) then + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + else + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + end if + + fname = trim(this_view % filename(ifile)) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,1), bc1, bc2, fk1, fk2 ) + + bt_p = missing_r + where (readmask_p) + bt_p(:,:,1) = rad2bt(rad_p(:,:,1), bc1, bc2, fk1, fk2) + end where + + !JJG: It is possible for readmask_p to differ across channels. + ! readmask_p needs to be incorporated, but presently causes error between channel reading + ! when lining up channels to identical members of linked p list. + ! Fixing this will require moving away from linked list including the readmask_p quality + ! flag in the datalink_type. + ! Presently readmask_p is used internally within get_abil1b_rad to set rad_p=missing_r (works fine) + !allmask_p = (allmask_p .and. readmask_p) + if ( TEMPIR_ifile.gt.0 ) then + fname = trim(this_view % filename(TEMPIR_ifile)) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,2), bc1, bc2, fk1, fk2 ) + + where (readmask_p) + bt_p(:,:,2) = rad2bt(rad_p(:,:,2), bc1, bc2, fk1, fk2) + end where + + yr = this_view % filedate(TEMPIR_ifile) % yr + mt = this_view % filedate(TEMPIR_ifile) % mt + dy = this_view % filedate(TEMPIR_ifile) % dy + hr = this_view % filedate(TEMPIR_ifile) % hr + mn = this_view % filedate(TEMPIR_ifile) % mn + sc = this_view % filedate(TEMPIR_ifile) % sc +! write(unit=stdout, & +! fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & +! ' TEMPIR time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + end if + + first_chan = (this_view % nfiles_used(ifgat).eq.1) + + !! Write bt, lat, lon, satzen, satazi, solzen, solazi to datalink structures + if (first_chan) then + p_fgat => p + + yr = this_view % filedate(ifile) % yr + mt = this_view % filedate(ifile) % mt + dy = this_view % filedate(ifile) % dy + hr = this_view % filedate(ifile) % hr + mn = this_view % filedate(ifile) % mn + sc = this_view % filedate(ifile) % sc + + allocate( solzen_1d (this_view % nrad_on_patch) ) + allocate( solazi_1d (this_view % nrad_on_patch) ) + + call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & + this_view % lat_1d % patch, this_view % lon_1d % patch, & + solzen_1d, solazi_1d ) + + if ( use_clddet_zz .and. & + abi_halo_width-abi_superob_halfwidth.ge.1) then + ! Allocate terrain_hgt using local indices for this view + allocate( terrain_hgt ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + + ! Read terrain file using Full Disk global indices + write(*,*) 'DEBUG da_read_obs_ncgoesabi, ys_local, ye_local, yoff_fd-1: ', & + this_view % ys_local, this_view % ye_local, this_view % yoff_fd-1 + write(*,*) 'DEBUG da_read_obs_ncgoesabi, xs_local, xe_local, xoff_fd-1: ', & + this_view % xs_local, this_view % xe_local, this_view % xoff_fd-1 + + call get_abil1b_terr( terr_fname, & + this_view % ys_local + this_view % yoff_fd - 1, & + this_view % ye_local + this_view % yoff_fd - 1, & + this_view % xs_local + this_view % xoff_fd - 1, & + this_view % xe_local + this_view % xoff_fd - 1, & + terrain_hgt ) + + end if + + allocate(thinmask(this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p)) + thinmask = .false. + else + p => p_fgat + end if + + PixelLoop: do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + + if (.not. allmask_p( iy, ix )) cycle PixelLoop + + if (first_chan) then + info % lat = this_view % lat_1d % patch (n) ! latitude + info % lon = this_view % lon_1d % patch (n) ! longitude + num_goesabi_local = num_goesabi_local + 1 + end if + + if (thinning) then + if (first_chan) then + dlat_earth = info % lat + dlon_earth = info % lon + if (dlon_earth=r360) dlon_earth = dlon_earth-r360 + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad + crit = 1. + call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) + if (.not. iuse) then + num_goesabi_thinned=num_goesabi_thinned+1 + thinmask( iy, ix ) = .true. + cycle PixelLoop + end if + else + if (thinmask( iy, ix )) cycle PixelLoop + end if + end if + + if (first_chan) then + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) + 1 + + allocate ( p % tb_inv (1:nchan) ) + allocate ( p % rad_obs (1:nchan) ) + p % tb_inv = missing_r + p % rad_obs = missing_r + + write(unit=info % date_char, & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + if ( allocated(terrain_hgt) ) then + info % elv = terrain_hgt( iy, ix ) + else + info % elv = 0.0 + end if + p % info = info + p % loc = this_view % loc_1d % patch (n) + + p % landsea_mask = 1 ! ??? + if (use_view_mask) then + p % scanpos = & + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) + else + p % scanpos = & + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5424 + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) + end if + p % satzen = this_view % satzen_1d % patch (n) + p % satazi = this_view % satazi_1d % patch (n) + p % solzen = solzen_1d (n) + p % solazi = solazi_1d (n) + if ( p % solzen < 0. ) p % solzen = 150. + p % sensor_index = inst + p % ifgat = ifgat + end if + + ! Super-ob the radiance, then convert to BT for this channel + tbuf = abi_superob_halfwidth + if (abi_halo_width.ge.tbuf .and. tbuf.gt.0) then + ! require that nkeep >= superob_width to filter out bad data + nkeep = count ( rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .ge. superob_width) then + p % rad_obs(ichan) = sum( pack( & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) ) & + / real(nkeep,r_double) + end if + else + ! Extract single pixel BT and radiance value for this channel + p % rad_obs(ichan) = rad_p( iy, ix, 1 ) + end if + if (p % rad_obs(ichan) .gt. 0.0) then + p % tb_inv(ichan) = rad2bt(p % rad_obs(ichan), bc1, bc2, fk1, fk2 ) + end if + + ! Preprocessing for Cloud Mask (da_qc_goesabi.inc) including + ! extracting Tb values from cloud QC buffer + if (.not. allocated(p % superob)) then + allocate( p % superob(superob_width,superob_width) ) + end if + + ! Loops over superob pixels + do jsup = 1, superob_width + do isup = 1, superob_width + iysup = iy + jsup-1-abi_superob_halfwidth + ixsup = ix + isup-1-abi_superob_halfwidth + if (first_chan) then + allocate ( p % superob(isup,jsup) % tb_obs (1:nchan,1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(nchan) ) + end if + p % superob(isup,jsup) % tb_obs(ichan,1) = bt_p( iysup, ixsup, 1 ) + + tbuf = 1 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + nkeep = count ( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ), & + bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = sigma + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + end if + if (channel_list(ichan).eq.14) then + + if ( allocated(terrain_hgt) ) then + ! Determine sigma_z of terrain height across these pixels + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = terrain_hgt( iysup, ixsup ) + nkeep = count ( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ), & + terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + + temp_max = 0. + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + if (temp_max .gt. missing_r) then + ! Store RTCT + p % superob(isup,jsup) % cld_qc(1) % RTCT = temp_max - bt_p( iysup, ixsup, 1 ) - & + 3.0_r_double * 0.007_r_double * sigma + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + end if + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + end if + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r + end if + + end if + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r + end if + end if + + ! Values for RFMFT cloud QC + ! - channels 14 and 15 + tbuf = 10 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + !Determine Neighboring Warm Center (NWC) for this pixel + temp_max = 0.0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( bt_p( jy, jx, 1 ) .gt. temp_max ) then + temp_max = bt_p( jy, jx, 1 ) + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1) = jy + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2) = jx + end if + end do + end do + p % superob(isup,jsup) % cld_qc(1) % RFMFT = & + bt_p( iysup, ixsup, 1 ) - temp_max + end if + if (channel_list(ichan).eq.15 .and. & + all(p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij.gt.0)) then + + temp_max = bt_p ( p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1), & + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2), 1 ) + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = abs( & + p % superob(isup,jsup) % cld_qc(1) % RFMFT + & + temp_max - bt_p( iysup, ixsup, 1 ) ) + + end if + else + if ( any( channel_list(ichan).eq.(/14,15/) ) ) then + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = missing_r + + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + end if + end if + + ! Values for CIRH2O cloud QC + ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test + tbuf = 2 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + + if (channel_list(ichan).eq.10) then + + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ( & + iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 2 ) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,1) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + + end if + if (channel_list(ichan).eq.14 .and. & + size(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi).gt.1) then + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,2) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + nkeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 + end do + end do + allocate( tb_temp ( nkeep, 2 ) ) + ikeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) then + ikeep = ikeep + 1 + tb_temp(ikeep,1) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 1 ) + tb_temp(ikeep,2) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 2 ) + end if + end do + end do + + mu10 = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma10 = sqrt( sum( (tb_temp(:,1) - mu10)**2 ) & + / real(nkeep,r_double) ) + + mu14 = sum( tb_temp(:,2) ) / real(nkeep,r_double) + sigma14 = sqrt( sum( (tb_temp(:,2) - mu14)**2 ) / & + real(nkeep,r_double) ) + + pearson = sum((tb_temp(:,1) - mu10) * (tb_temp(:,2) - mu14)) / & + real(nkeep,r_double) / ( sigma10 * sigma14 ) + + deallocate( tb_temp ) + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = pearson + + end if + else + if ( any( channel_list(ichan).eq.(/10,14/) ) ) then + + if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi) + + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1)) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = missing_r + + end if + end if + + ! Values for TEMPIR cloud QC + ! - channel 14 + if ( use_clddet_zz .and. (channel_list(ichan).eq.14) ) then + + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = missing_r + + if ( TEMPIR_ifile.gt.0 .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0 .and. & + bt_p( iysup, ixsup, 2 ).gt.0.0 ) then + if ( bt_p( iysup, ixsup, 2 ).lt.330. ) & + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = & + bt_p( iysup, ixsup, 2 ) - bt_p( iysup, ixsup, 1 ) + end if + + end if + end do ! isup + end do ! jsup + + if (first_chan) & + allocate (p % next) ! add next data + + p => p % next + + if (first_chan) & + nullify (p % next) + + end do PixelLoop + if ( allocated(bt_p) ) deallocate ( bt_p ) + if ( allocated(rad_p) ) deallocate ( rad_p ) + if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) + if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) + if ( allocated(allmask_p) ) deallocate ( allmask_p ) + if ( allocated(readmask_p) ) deallocate ( readmask_p ) + end if VIEW_SELECT + end do ChannelLoop + if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) + if ( allocated(thinmask) ) deallocate ( thinmask ) + else + write(unit=stdout,fmt='(A)') & + ' No pixels to read within this subdomain. Waiting for other processors...' + end if PatchMatch + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + end do fgat_loop ! end fgat loop + + if ( (this_view % moving .or. ipass.eq.npass) .and. this_view%nrad_on_patch.gt.0 ) then + ! Deallocate location info + deallocate ( this_view % patchmask ) + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) + end if + + if (ipass .eq. 2) tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) + + end do ! end view loop + + end do ! end pass loop + + if ( allocated(view_mask) ) deallocate(view_mask) + + do iview = 1, nviews + if ( .not.view_att(iview) % select ) cycle + this_view => view_att(iview) + deallocate ( this_view % filename ) + deallocate ( this_view % filechan ) + deallocate ( this_view % filedate ) + deallocate ( this_view % file_fgat_match ) + deallocate ( this_view % fgat_time_abs_diff ) + deallocate ( this_view % min_time_diff ) + deallocate ( this_view % nfiles_used ) + if ( allocated( this_view % ny_grid ) ) deallocate ( this_view % ny_grid ) + if ( allocated( this_view % nx_grid ) ) deallocate ( this_view % nx_grid ) + if ( allocated( this_view % ys_grid ) ) deallocate ( this_view % ys_grid ) + if ( allocated( this_view % xs_grid ) ) deallocate ( this_view % xs_grid ) + end do + deallocate(view_att) + + if (tot_files_used .lt. 1) then + write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, " for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." + +! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" +! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" +! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, " for this process rank." +! write(unit=message(4),fmt='(A)') "This subdomain may have an unacceptable zenith " +! write(unit=message(5),fmt='(A)') "angle or fall entirely outside the GOES viewing" +! write(unit=message(6),fmt='(A)') "extent." + + call da_warning(__FILE__,__LINE__, message(1:1)) + end if + +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_local, & + num_goesabi_global, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + num_goesabi_global = num_goesabi_local +#endif + +!------------------------------------------------------ + ! NOTE: Remainder of this subroutine modified from da_read_obs_ncgoesimg.inc + + if (thinning .and. num_goesabi_global > 0 ) then +#ifdef DM_PARALLEL + + ! Get minimum crit and associated processor index. + j = 0 + do ifgat = 1, num_fgat_time + j = j + thinning_grid(inst,ifgat) % itxmax + end do + + + allocate ( in (j) ) + allocate ( out (j) ) + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat) % itxmax + j = j + 1 + in(j) = thinning_grid(inst,ifgat) % score_crit(i) + end do + end do + + call mpi_reduce(in, out, j, true_mpi_real, mpi_min, root, comm, ierr) + + call wrf_dm_bcast_real (out, j) + + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat) % itxmax + j = j + 1 + if ( ABS(out(j)-thinning_grid(inst,ifgat) % score_crit(i)) > 1.0D-10 ) thinning_grid(inst,ifgat) % ibest_obs(i) = 0 + end do + end do + deallocate( in ) + deallocate( out ) + +#endif + ! Delete the nodes being thinned out + p => head + prev => head + head_found = .false. + num_goesabi_used_tmp = sum(num_goesabi_used_fgat) + + do j = 1, num_goesabi_used_tmp + n = p % sensor_index + ifgat = p % ifgat + found = .false. + + do i = 1, thinning_grid(n,ifgat) % itxmax + if ( thinning_grid(n,ifgat) % ibest_obs(i) == j .and. thinning_grid(n,ifgat) % score_crit(i) < 9.99e6_r_double ) then + found = .true. + exit + end if + end do + + ! free current data + if ( .not. found ) then + current => p + p => p % next + if ( head_found ) then + prev % next => p + else + head => p + prev => p + end if + deallocate ( current % tb_inv ) + deallocate ( current % rad_obs ) + if ( allocated( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) + end if + deallocate ( current ) + num_goesabi_thinned = num_goesabi_thinned + 1 + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) - 1 + continue + end if + + if ( found .and. head_found ) then + prev => p + p => p % next + continue + end if + if ( found .and. .not. head_found ) then + head_found = .true. + head => p + prev => p + p => p % next + end if + + end do + + end if ! End of thinning +!stop + num_goesabi_used = sum(num_goesabi_used_fgat) + iv % total_rad_pixel = iv % total_rad_pixel + num_goesabi_used + iv % total_rad_channel = iv % total_rad_channel + num_goesabi_used*nchan + + iv % info(radiance) % nlocal = iv % info(radiance) % nlocal + num_goesabi_used + iv % info(radiance) % ntotal = iv % info(radiance) % ntotal + num_goesabi_global + + do i = 1, num_fgat_time +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_used_fgat(i), & + ptotal(i), & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + ptotal(i) = num_goesabi_used_fgat(i) +#endif + end do + + do i = 1, num_fgat_time + ptotal(i) = ptotal(i) + ptotal(i-1) + iv % info(radiance) % ptotal(i) = iv % info(radiance) % ptotal(i) + ptotal(i) + end do + +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_thinned, & + nthinned, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nthinned = num_goesabi_thinned +#endif + + if ( iv % info(radiance) % ptotal(num_fgat_time) /= (iv % info(radiance) % ntotal - nthinned) ) then + write(unit=message(1),fmt='(A,I10,A,I10)') & + "Number of ntotal - nthinned:",iv % info(radiance) % ntotal - nthinned," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) + call da_warning(__FILE__,__LINE__,message(1:1)) + endif + + write(unit=stdout,fmt='(a)') 'num_goesabi_global, num_goesabi_thinned_global, num_goesabi_used_global' + write(unit=stdout,fmt=*) num_goesabi_global, nthinned, ptotal(num_fgat_time) + + write(unit=stdout,fmt='(a)') 'num_goesabi_local, num_goesabi_thinned, num_goesabi_used' + write(unit=stdout,fmt=*) num_goesabi_local, num_goesabi_thinned, num_goesabi_used + + ! 5.0 allocate innovation radiance structure + !---------------------------------------------------------------- + + + if (num_goesabi_used > 0) then + iv % instid(inst) % num_rad = num_goesabi_used + iv % instid(inst) % info % nlocal = num_goesabi_used + write(unit=stdout,FMT='(a,i3,2x,a,3x,i10)') & + 'Allocating space for radiance innov structure', & + inst, iv % instid(inst) % rttovid_string, iv % instid(inst) % num_rad + call da_allocate_rad_iv (inst, nchan, iv) + end if + + ! 6.0 assign sequential structure to innovation structure + !------------------------------------------------------------- + p => head + do n = 1, num_goesabi_used + i = p % sensor_index + call da_initialize_rad_iv (i, n, iv, p) + current => p + p => p % next + + ! free current data + deallocate ( current % tb_inv ) + deallocate ( current % rad_obs ) + if ( allocated ( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) + end if + deallocate ( current ) + end do + deallocate ( p ) + deallocate (ptotal) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + if (trace_use) call da_trace_exit("da_read_obs_ncgoesabi") + +end subroutine da_read_obs_ncgoesabi + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) + + implicit none + + integer, intent(in) :: channel, nchan + integer, intent(in) :: channel_list(nchan) + integer, intent(out) :: ichan + integer :: i + + if (trace_use) call da_trace_entry("get_ichan") + + ichan = 0 + do i = 1, nchan + if (channel .eq. channel_list(i)) then + ichan = i + exit + end if + end do + + if (trace_use) call da_trace_exit("get_ichan") + +end subroutine get_ichan + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_metadata( filename, & + ydim, xdim, req, rpol, pph, nam) !, lat_sat, lon_sat ) + + implicit none + + character(*), intent(in) :: filename + integer, intent(out) :: ydim, xdim + real(r_double), intent(out) :: req, rpol, pph, nam +!!! real, intent(out) :: lat_sat, lon_sat + + integer :: ierr, ncid, varid, dimid + + if (trace_use) call da_trace_entry("get_abil1b_metadata") + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) + + !! Determine ABI satellite parameters (optional outputs) + ierr=nf_inq_dimid(ncid,'y',dimid) + ierr=nf_inq_dimlen(ncid,dimid,ydim) + ierr=nf_inq_dimid(ncid,'x',dimid) + ierr=nf_inq_dimlen(ncid,dimid,xdim) + + ierr=nf_inq_varid(ncid,'goes_imager_projection',varid) + ierr=nf_get_att_double(ncid,varid,'semi_major_axis',req) + ierr=nf_get_att_double(ncid,varid,'semi_minor_axis',rpol) + ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) + ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) + nam = nam * deg2rad + +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) +!!! ierr=nf_get_var_double(ncid,varid,lat_sat) +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lon',varid) +!!! ierr=nf_get_var_double(ncid,varid,lon_sat) + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_metadata") + +end subroutine get_abil1b_metadata + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_grid1( filename, & + ny, nx, & + yy_abi, xx_abi, & + yoff, xoff ) + + implicit none + + character(*), intent(in) :: filename + integer, intent(in) :: ny, nx + real, intent(out) :: yy_abi(ny), xx_abi(nx) + integer, intent(out) :: yoff, xoff + + integer :: ierr, ncid, varid + real :: slp, itp + + if (trace_use) call da_trace_entry("get_abil1b_grid1") + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid(ncid,'y',varid) + + ierr=nf_get_var_double(ncid,varid,yy_abi) + + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + yy_abi = yy_abi*slp+itp + yoff = floor(itp/slp) + + ierr=nf_inq_varid(ncid,'x',varid) + + ierr=nf_get_var_double(ncid,varid,xx_abi) + + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + xx_abi = xx_abi*slp+itp + xoff = floor(itp/slp) + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_grid1") + +end subroutine get_abil1b_grid1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, satazi, & + earthmask, zenmask ) + + implicit none + + real, intent(in) :: yy_abi(:), xx_abi(:) + real(r_double), intent(in) :: req, rpol, pph, nam + integer, intent(in) :: satellite_id + + ! GOES-ABI fields + real, intent(out) :: lat(:), lon(:) + real, intent(out) :: satzen(:), satazi(:) + logical, intent(out) :: earthmask(:), zenmask(:) + + ! Internal Variables + type(info_type) :: info + logical :: outside_all, dummy_bool + + integer :: iy, ix, n + real(r_double) :: hh + real, parameter :: satzen_limit=75.0 + + if (trace_use) call da_trace_entry("get_abil1b_grid2_1d") + + lat = missing_r + lon = missing_r + satzen = missing_r + satazi = missing_r + earthmask=.true. + zenmask=.true. + + hh=pph+req + + call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & + isnan(lat) .OR. isnan(lon) ) + earthmask = .false. + lat = missing_r + lon = missing_r + end where + + call da_get_sat_angles_1d( lat, lon, satellite_id, satzen, satazi ) + + where ( isnan(satzen) .or. satzen.gt.satzen_limit .or. satzen.eq.missing_r ) + satzen = missing_r + zenmask = .false. + end where + + if (trace_use) call da_trace_exit("get_abil1b_grid2_1d") + +end subroutine get_abil1b_grid2_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_rad( filename, ys, ye, xs, xe, radmask, inst, ichan, & + radout, bc1, bc2, fk1, fk2 ) + implicit none + + character(*), intent(in) :: filename + + !Size of full data set + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + integer, intent(in) :: inst, ichan + + logical, intent(inout) :: radmask( ys:ye, xs:xe ) + real, intent(out) :: radout( ys:ye, xs:xe ) + real, intent(out) :: bc1, bc2, fk1, fk2 + + real :: rad(xs:xe, ys:ye) + integer :: DQF(xs:xe, ys:ye) + + integer :: ierr, ncid, varid + integer :: iy, ix + integer :: nykeep, nxkeep + real :: slp, itp + + if (trace_use) call da_trace_entry("get_abil1b_rad") + + rad = missing_r + + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 + + if (nykeep.le.0 .or. nxkeep.le.0) then + radmask = .false. + return + end if + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid( ncid, 'Rad', varid ) + ierr=nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), rad ) + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + rad=rad*slp+itp + + ierr=nf_inq_varid ( ncid, 'DQF', varid ) + ierr=nf_get_vara_int ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), DQF ) + + ierr=nf_inq_varid( ncid, 'planck_bc1', varid ) + ierr=nf_get_var_double( ncid, varid, bc1 ) + ierr=nf_inq_varid( ncid, 'planck_bc2', varid ) + ierr=nf_get_var_double( ncid, varid, bc2 ) + ierr=nf_inq_varid( ncid, 'planck_fk1', varid ) + ierr=nf_get_var_double( ncid, varid, fk1 ) + ierr=nf_inq_varid( ncid, 'planck_fk2', varid ) + ierr=nf_get_var_double( ncid, varid, fk2 ) + + radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) ) + radmask = ( radmask .and. transpose(rad).gt.0.0 ) + + radout = missing_r + where ( radmask ) + radout = transpose(rad) + end where + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_rad") + +end subroutine get_abil1b_rad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function rad2bt( rad, bc1, bc2, fk1, fk2 ) result(bt) + implicit none + + real, intent(in) :: rad + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: bt + + bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + +end function rad2bt + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function bt2rad( bt, bc1, bc2, fk1, fk2 ) result(rad) + implicit none + + real, intent(in) :: bt + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: rad + + rad = fk1 / ( exp( fk2 / (bc1 + bc2 * bt)) - 1.0 ) + +end function bt2rad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) + implicit none + + character(*), intent(in) :: filename + + !Size of full data set + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + real, intent(out) :: terr( ys:ye, xs:xe ) ! unit = meters + + real :: terr_trans( xs:xe, ys:ye ) ! unit = meters + integer :: ncid, varid + integer :: nykeep, nxkeep + real :: terr_miss + + if (trace_use) call da_trace_entry("get_abil1b_terr") + + terr = missing_r + + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 + + if (nykeep.le.0 .or. nxkeep.le.0) then + return + end if + + call handle_err ( 'Error opening file', & + nf_open(trim(filename),nf_nowrite,ncid) ) + call handle_err ( 'Error getting terr ID', & + nf_inq_varid( ncid, 'terr', varid ) ) + + write(*,*) 'DEBUG get_abil1b_terr, xs, ys, xs+nxkeep, ys+nykeep: ',xs,ys,xs+nxkeep,ys+nykeep + + call handle_err ( 'Error reading terrain height', & + nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), terr_trans ) ) + terr = transpose(terr_trans) + + call handle_err ( 'Error with _FillValue', & + nf_get_att_double(ncid, varid, '_FillValue', terr_miss) ) + + where ( terr .le. terr_miss ) & + terr = missing_r + + call handle_err('Error closing file', & + nf_close(ncid) ) + + if (trace_use) call da_trace_exit("get_abil1b_terr") + +end subroutine get_abil1b_terr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_latlon_1d( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + implicit none + + real, intent(in) :: yy_abi(:), xx_abi(:) + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat(:), lon(:) + + real, allocatable :: lat1(:), lon1(:) + real, allocatable :: aa(:), bb(:), cc(:), rs(:), sx(:), sy(:), sz(:) + real, allocatable :: radicand(:) + integer :: n + + if (trace_use) call da_trace_entry("get_abil1b_latlon_1d") + + n = size(yy_abi) + + allocate ( lat1( n ) ) + allocate ( lon1( n ) ) + allocate ( aa( n ) ) + allocate ( bb( n ) ) + allocate ( cc( n ) ) + allocate ( rs( n ) ) + allocate ( sx( n ) ) + allocate ( sy( n ) ) + allocate ( sz( n ) ) + allocate ( radicand( n ) ) + + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2 ) + + bb = -2.D0 * hh * cos( xx_abi ) * cos( yy_abi ) + + cc = hh**2-req**2 + + radicand = bb ** 2 - 4.D0 * aa * cc + + where ( radicand .ge. 0. ) + rs = ( -bb - sqrt( radicand ) ) / ( 2.D0 * aa ) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) + + lat1 = atan( req**2 / rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam - atan( sy / ( hh - sx ) ) + + lat = lat1 / deg2rad + lon = lon1 / deg2rad + end where + + deallocate ( lat1, lon1, aa, bb, cc, rs, sx, sy, sz, radicand ) + + if (trace_use) call da_trace_exit("get_abil1b_latlon_1d") + +end subroutine get_abil1b_latlon_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_latlon( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + implicit none + + real, intent(in) :: yy_abi, xx_abi + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat,lon + + real :: lat1,lon1 + real :: aa,bb,cc,rs,sx,sy,sz + real :: radicand + + if (trace_use) call da_trace_entry("get_abil1b_latlon") + + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2) + bb = -2.D0*hh * cos( xx_abi ) * cos( yy_abi ) + cc = hh**2 - req**2 + + radicand = bb **2 - 4.D0 * aa * cc + if (radicand .lt. 0.) return + + rs = ( -bb - sqrt( radicand ) )/(2.D0 * aa) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) + + lat1 = atan( req**2/rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam-atan( sy / ( hh - sx ) ) + + lat = lat1 / deg2rad + lon = lon1 / deg2rad + + if (trace_use) call da_trace_exit("get_abil1b_latlon") + +end subroutine get_abil1b_latlon + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef DM_PARALLEL +subroutine split_grid( ny_global, nx_global, & + ny_grid, nx_grid, & + ys_grid, xs_grid ) + implicit none + + integer, intent(in) :: ny_global, nx_global + integer, intent(out) :: ny_grid(num_procs), nx_grid(num_procs), & + ys_grid(num_procs), xs_grid(num_procs) + + integer, target :: ny_vec(ntasks_y), ys_vec(ntasks_y) !, ye_vec(ntasks_y) + integer, target :: nx_vec(ntasks_x), xs_vec(ntasks_x) !, xe_vec(ntasks_x) + integer, pointer :: nvec(:), svec(:) + + integer :: mm, i, j, ii, iproc, igrid, ntasks, nglobal, fact + + do igrid = 1, 2 + if (igrid.eq.1) then + nvec => ny_vec + svec => ys_vec + ntasks = ntasks_y + nglobal = ny_global + else if (igrid.eq.2) then + nvec => nx_vec + svec => xs_vec + ntasks = ntasks_x + nglobal = nx_global + end if + + nvec = nglobal / ntasks + mm = mod( nglobal , ntasks ) + do j = 1, ntasks + if ( mm .eq. 0 ) exit + nvec(j) = nvec(j) + 1 + mm = mm - 1 + end do + + svec(1) = 1 + do j = 1, ntasks + if (j .lt. ntasks) then + svec(j+1) = svec(j) + nvec(j) + end if + end do + end do + + iproc = 0 + do j = 1, ntasks_y + do i = 1, ntasks_x + iproc = iproc + 1 + ny_grid(iproc) = ny_vec(j) + ys_grid(iproc) = ys_vec(j) + nx_grid(iproc) = nx_vec(i) + xs_grid(iproc) = xs_vec(i) + end do + end do + +end subroutine split_grid +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine jday2cal(jdy, yr, mt, dy) + implicit none + integer, intent(in) :: jdy, yr + integer, intent(out) :: mt, dy + integer :: d_in_m(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + integer :: imonth, tot_days + if ( mod(yr,4).eq.0 .and. .not.(mod(yr,100).eq.0 .and. .not.mod(yr,400).eq.0) ) d_in_m(2) = 29 + tot_days = 0 + do imonth = 1, 12 + tot_days = tot_days + d_in_m(imonth) + if (tot_days .ge. jdy) then + mt = imonth + dy = jdy - ( tot_days - d_in_m(imonth) ) + exit + end if + end do +end subroutine jday2cal + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) + ! Converts modified Julian time (in minutes) to Gregorian calender date + ! Modified from this code: David G. Simpson, NASA Goddard, Accessed April 2018 + ! https://caps.gsfc.nasa.gov/simpson/software.html + + implicit none + + real(r_double), intent(in) :: jmod + integer, intent(out) :: yr,mt,dy,hr,mn + integer, intent(out), optional :: sc + + real(r_double) :: ju, j0, F + integer :: yr0, sc0 + INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables + real(r_double) :: dd + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 2443510.0 + + ! Convert to days + ju = jmod / 1440.D0 + + !! Convert reference MJD to actual Julian time + ju = ju+jd_jmod + Z = INT(ju) + F = ju - Z + + !! Gregorian date test (can probably assume this is a Gregorian date) + IF (Z .LT. 2299161) THEN + A = Z + ELSE + ALPHA = INT((Z-1867216.25D0)/36524.25D0) + A = Z + 1 + ALPHA - ALPHA/4 + END IF + + B = A + 1524 + C = INT((B-122.1D0)/365.25D0) + D = INT(365.25D0*C) + E = INT((B-D)/30.6001D0) + + IF (E .LT. 14) THEN + mt = E - 1 + ELSE + mt = E - 13 + END IF + + IF (mt .GT. 2) THEN + yr = C - 4716 + ELSE + yr = C - 4715 + END IF + + dd = B - D - INT(30.6001D0*E) + F + + dy = floor(dd) + + !! Remainder for hr, mn, sc. + dd = dd - real(dy,8) + + sc0 = nint(dd*86400.) + hr = sc0 / 3600 + sc0 = sc0 - hr*3600 + mn = sc0 / 60 + if (present(sc)) sc = sc0 - mn*60 + +end subroutine da_get_cal_time + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine handle_err(rmarker,nf_status) + implicit none + integer, intent(in) :: nf_status + character*(*), intent(in) :: rmarker + if (nf_status .ne. nf_noerr) then + write(*,*) 'NetCDF error : ',rmarker + write(*,*) ' ',nf_strerror(nf_status) + stop + endif +end subroutine handle_err + diff --git a/var/da/da_radiance/da_rttov.f90 b/var/da/da_radiance/da_rttov.f90 index 46e71c55b5..9bad0db61f 100644 --- a/var/da/da_radiance/da_rttov.f90 +++ b/var/da/da_radiance/da_rttov.f90 @@ -31,9 +31,11 @@ module da_rttov num_fgat_time,stdout,trace_use, use_error_factor_rad, & qc_good, qc_bad,myproc,biascorr, global,ims,ime,jms,jme, & use_clddet, time_slots, rttov_emis_atlas_ir, rttov_emis_atlas_mw, & - use_mspps_emis, use_mspps_ts + use_mspps_emis, use_mspps_ts, use_clddet_zz use da_interpolation, only : da_to_zk_new, & - da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj + da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj, & + da_interp_2d_partial + use da_physics, only: da_trop_wmo use da_tools_serial, only : da_get_unit, da_free_unit #ifdef DM_PARALLEL use da_par_util, only : true_mpi_real diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index cdf9f9238b..10f5f1c724 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -217,6 +217,13 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) !end if !write(unit=stdout,fmt='(a)') 'Finish reading goesimg data' end if + if (use_goesabiobs) then + write(unit=stdout,fmt='(a)') 'Reading netcdf goes ABI radiance data' + + call da_read_obs_ncgoesabi(iv, 16) + + call da_read_obs_ncgoesabi(iv, 17) + end if if (use_gmiobs) then #if defined(HDF5) write(unit=stdout,fmt='(a)') 'Reading GMI data in HDF5 format' diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index c5a6fa84dd..efb3b2874c 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -18,7 +18,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2, ahi + logical :: amsr2, ahi, abi real :: cip ! to output cloud-ice path integer :: cloudflag ! to output cloudflag integer, dimension(1) :: maxl @@ -59,6 +59,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) endif amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 ahi = index(iv%instid(i)%rttovid_string,'ahi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -177,7 +178,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') ob%instid(i)%tb(:,n) write(unit=innov_rad_unit,fmt='(a)') 'BAK : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb(:,n) - if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi) ) then + if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi .or. abi) ) then write(unit=innov_rad_unit,fmt='(a)') 'BAK_clr : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) endif @@ -197,6 +198,14 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs + write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'COBS : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 2f058839df..613cbcf4c5 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -19,7 +19,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2 + logical :: amsr2, abi if (trace_use) call da_trace_entry("da_write_oa_rad_ascii") @@ -40,6 +40,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) if (ndomain < 1) cycle amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -141,6 +142,14 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, cloud_flag + write(unit=oma_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'COBS : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index 2fbfdd0a9c..ba3ad3f581 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -161,6 +161,8 @@ module module_radiance integer, pointer :: iuse (:) ! usage flag (-1: not use) from radiance info file real , pointer :: error(:) ! error Standard Deviation from radiance info file real , pointer :: error_cld(:) ! error Standard Deviation for cloudy radiance from radiance info file + real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI + real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI real , pointer :: polar(:) ! polarisation (0:ver; 1:hori) from radiance info file real , pointer :: error_factor(:) ! error tuning factor ! from error tuning file ! new air mass bias correction coefs. diff --git a/var/da/da_setup_structures/da_setup_obs_structures.inc b/var/da/da_setup_structures/da_setup_obs_structures.inc index 76573c9647..e627396308 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures.inc @@ -67,6 +67,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. @@ -103,7 +107,7 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_ssmisobs .OR. use_hirs4obs .OR. use_mhsobs .OR. use_pseudo_rad .OR. & use_mwtsobs .OR. use_mwhsobs .OR. use_atmsobs .OR. use_simulated_rad .OR. & use_iasiobs .OR. use_seviriobs .OR. use_amsr2obs .OR. use_goesimgobs .OR. & - use_ahiobs .OR. use_mwhs2obs .OR. use_gmiobs) then + use_ahiobs .OR. use_mwhs2obs .OR. use_gmiobs .OR. use_goesabiobs) then use_rad = .true. else use_rad = .false. @@ -154,6 +158,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. @@ -427,6 +435,15 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) if ( use_amsr2obs ) then call da_message((/'Using AMSR2 radiance input in HDF5 format'/)) end if + if ( use_goesimgobs ) then + call da_message((/'Using GOES IMAGER radiance input in netcdf format'/)) + end if + if ( use_goesabiobs ) then + call da_message((/'Using GOES ABI radiance input in netcdf format'/)) + end if + if ( use_ahiobs ) then + call da_message((/'Using himawari AHI radiance input in netcdf format'/)) + end if if ( use_gmiobs ) then call da_message((/'Using GMI radiance input in HDF5 format'/)) end if diff --git a/var/da/da_setup_structures/da_setup_structures.f90 b/var/da/da_setup_structures/da_setup_structures.f90 index 22997feacc..c94e5daf06 100644 --- a/var/da/da_setup_structures/da_setup_structures.f90 +++ b/var/da/da_setup_structures/da_setup_structures.f90 @@ -74,7 +74,7 @@ module da_setup_structures chi_u_t_factor, chi_u_ps_factor,chi_u_rh_factor, t_u_rh_factor, ps_u_rh_factor, & interpolate_stats, be_eta, thin_rainobs, fgat_rain_flags, use_iasiobs, & use_seviriobs, jds_int, jde_int, anal_type_hybrid_dual_res, use_amsr2obs, nrange, use_4denvar, & - use_goesimgobs, use_ahiobs,use_gmiobs, obs_use, thin_conv_opt, no_thin, & + use_goesimgobs, use_ahiobs, use_goesabiobs, use_gmiobs, obs_use, thin_conv_opt, no_thin, & thin_superob_hv, thin_mesh_vert_conv, use_satwnd_bufr use da_control, only: rden_bin, use_lsac use da_control, only: use_cv_w diff --git a/var/da/da_tools/da_llxy_1d.inc b/var/da/da_tools/da_llxy_1d.inc new file mode 100644 index 0000000000..0752830bc3 --- /dev/null +++ b/var/da/da_tools/da_llxy_1d.inc @@ -0,0 +1,115 @@ +subroutine da_llxy_1d ( infos, locs, outside, outside_all, do_xy, do_outside) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Author: JJ Guerrette, MMM/NCAR, Date: 05/23/2018 + ! Modified from da_llxy, including child subroutines + !----------------------------------------------------------------------- + + ! This routine converts (lat, lon) into (x,y) coordinates + + implicit none + + type(info_type), optional, intent(in) :: infos(:) + type(model_loc_type), intent(inout) :: locs(:) + logical , intent(out) :: outside(:) !wrt local domain + logical, optional, intent(out) :: outside_all(:) !wrt all domains + logical, optional, intent(in) :: do_xy, do_outside + logical :: do_xy_, do_outside_ + + if (trace_use) call da_trace_entry("da_llxy_1d") + + outside = .false. + + do_xy_ = .true. + if ( present(do_xy) ) do_xy_ = do_xy + if ( do_xy_ ) then + if (present(infos)) then + locs(:) % x = -1.0 + locs(:) % y = -1.0 + + ! get the (x, y) coordinates + if ( fg_format == fg_format_wrf_arw_regional ) then + call da_llxy_wrf_1d(map_info, infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else if (fg_format == fg_format_wrf_nmm_regional) then + call da_llxy_rotated_latlon_1d(infos(:)%lat, infos(:)%lon, map_info, locs(:)%x, locs(:)%y) + else if (global) then + call da_llxy_global_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else + call da_llxy_default_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + end if + else + message(1)='da_llxy_1d requires infos in order to determine x & y' + call da_error(__FILE__,__LINE__,message(1:1)) + end if + end if + +#ifdef A2C + call da_togrid_1d (locs(:)%x, its-3, ite+3, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-3, jte+3, locs(:)%j, locs(:)%dy, locs(:)%dym) +#else + call da_togrid_1d (locs(:)%x, its-2, ite+2, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-2, jte+2, locs(:)%j, locs(:)%dy, locs(:)%dym) +#endif + +! do_outside_ = .true. +! if ( present(do_outside) ) do_outside_ = do_outside +! if ( .not.do_outside_ ) return + + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all(:) = .false. + ! Do not check for global options + if (.not. global) then + outside_all = outside_all .or. & + (int(locs(:)%x) < ids) .or. (int(locs(:)%x) >= ide) .or. & + (int(locs(:)%y) < jds) .or. (int(locs(:)%y) >= jde) + outside = outside .or. outside_all + if (def_sub_domain) then + outside_all = outside_all .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + outside = outside .or. outside_all + end if + end if + end if + + if (fg_format == fg_format_kma_global) then + outside = outside .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) + + where (locs(:)%j == jde) + locs%j = locs%j - 1 + locs%dy = 1.0 + locs%dym = 0.0 + end where + + return + end if + + ! Check for edge of domain: + outside = outside .or. & + (locs(:)%i < ids) .or. (locs(:)%i >= ide) .or. & + (locs(:)%j < jds) .or. (locs(:)%j >= jde) + + ! FIX? hack + outside = outside .or. & +#ifdef A2C + (locs(:)%i < its-2) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-2) .or. (locs(:)%j > jte) +#else + (locs(:)%i < its-1) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) +#endif + + if (def_sub_domain) then + outside = outside .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + end if + + if (trace_use) call da_trace_exit("da_llxy_1d") + +end subroutine da_llxy_1d diff --git a/var/da/da_tools/da_llxy_default_1d.inc b/var/da/da_tools/da_llxy_default_1d.inc new file mode 100644 index 0000000000..011a9d8b74 --- /dev/null +++ b/var/da/da_tools/da_llxy_default_1d.inc @@ -0,0 +1,114 @@ +subroutine da_llxy_default_1d (xlati,xloni,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the (x,y) location (dot) in the mesoscale grids + ! ------- from latitudes and longitudes + ! + ! for global domain co-ordinates + ! + ! input: + ! ----- + ! xlat: latitudes + ! xlon: longitudes + ! + ! output: + ! ----- + ! x: the coordinate in x (i)-direction. + ! y: the coordinate in y (j)-direction. + ! + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: xlati(:), xloni(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: dxlon(:) + real, allocatable :: xlat(:), xlon(:) + real, allocatable :: xx(:), yy(:), cell(:), psx(:), r(:), flp(:) + real :: xc, yc + real :: psi0 + real :: centri, centrj + real :: ratio + real :: bb + real, parameter :: conv = 180.0 / pi + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_default_1d") + + n = size(xlati) + allocate ( dxlon(n), xlat(n), xlon(n), xx(n), yy(n), cell(n), psx(n), r(n), flp(n) ) + + xlon = xloni + xlat = xlati + + where (xlat .lt. -89.95) xlat = -89.95 + where (xlat .gt. +89.95) xlat = +89.95 + + dxlon = xlon - xlonc + where (dxlon > 180) dxlon = dxlon - 360.0 + where (dxlon < -180) dxlon = dxlon + 360.0 + + if (map_projection == 3) then + xc = 0.0 + yc = YCNTR + + cell = cos(xlat/conv)/(1.0+sin(xlat/conv)) + yy = -c2*alog(cell) + xx = c2*dxlon/conv + else + psi0 = (pole - phic)/conv + xc = 0.0 + + ! calculate x,y coords. relative to pole + + flp = cone_factor*dxlon/conv + + psx = (pole - xlat)/conv + + if (map_projection == 2) then + ! Polar stereographics: + bb = 2.0*(cos(psi1/2.0)**2) + yc = -earth_radius*bb*tan(psi0/2.0) + r = -earth_radius*bb*tan(psx/2.0) + else + ! Lambert conformal: + bb = -earth_radius/cone_factor*sin(psi1) + yc = bb*(tan(psi0/2.0)/tan(psi1/2.0))**cone_factor + r = bb*(tan(psx /2.0)/tan(psi1/2.0))**cone_factor + end if + + if (phic < 0.0) then + xx = r*sin(flp) + yy = r*cos(flp) + else + xx = -r*sin(flp) + yy = r*cos(flp) + end if + end if + + ! transform (1,1) to the origin + ! the location of the center in the coarse domain + + centri = real (coarse_ix + 1)/2.0 + centrj = real (coarse_jy + 1)/2.0 + + ! the (x,y) coordinates in the coarse domain + + x = (xx - xc)/coarse_ds + centri + y = (yy - yc)/coarse_ds + centrj + + ratio = coarse_ds / dsm + + ! only add 0.5 so that x/y is relative to first cross points: + + x = (x - start_x) * ratio + 0.5 + y = (y - start_y) * ratio + 0.5 + + deallocate ( dxlon, xlat, xlon, xx, yy, cell, psx, r, flp ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_default_1d") + +end subroutine da_llxy_default_1d + + diff --git a/var/da/da_tools/da_llxy_global_1d.inc b/var/da/da_tools/da_llxy_global_1d.inc new file mode 100644 index 0000000000..9565be5cf5 --- /dev/null +++ b/var/da/da_tools/da_llxy_global_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + if(fg_format == fg_format_wrf_arw_global) & + where (lat.le.start_lat) y = 1.0 + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_global_1d") + +end subroutine da_llxy_global_1d diff --git a/var/da/da_tools/da_llxy_kma_global_1d.inc b/var/da/da_tools/da_llxy_kma_global_1d.inc new file mode 100644 index 0000000000..cac3245601 --- /dev/null +++ b/var/da/da_tools/da_llxy_kma_global_1d.inc @@ -0,0 +1,36 @@ +subroutine da_llxy_kma_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_kma_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_kma_global_1d") + +end subroutine da_llxy_kma_global_1d + + diff --git a/var/da/da_tools/da_llxy_latlon_1d.inc b/var/da/da_tools/da_llxy_latlon_1d.inc new file mode 100644 index 0000000000..0b9e869ed9 --- /dev/null +++ b/var/da/da_tools/da_llxy_latlon_1d.inc @@ -0,0 +1,56 @@ +subroutine da_llxy_latlon_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a LATLON + ! (cylindrical equidistant) grid. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: deltalat(:) + real, allocatable :: deltalon(:) + real, allocatable :: lon360(:) + real :: latinc + real :: loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_latlon_1d") + + n = size(lat) + allocate ( deltalat(n), deltalon(n), lon360(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + deltalat = lat - proj%lat1 + deltalon = lon360 - proj%lon1 + + !For cylindrical equidistant, dx == dy + loninc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + latinc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + + ! Compute x/y + x = deltalon/loninc + y = deltalat/latinc + + x = x + proj%knowni + y = y + proj%knownj + + deallocate ( deltalat, deltalon, lon360 ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_latlon_1d") + +end subroutine da_llxy_latlon_1d + + diff --git a/var/da/da_tools/da_llxy_lc_1d.inc b/var/da/da_tools/da_llxy_lc_1d.inc new file mode 100644 index 0000000000..b56e07b789 --- /dev/null +++ b/var/da/da_tools/da_llxy_lc_1d.inc @@ -0,0 +1,64 @@ +subroutine da_llxy_lc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: compute the geographical latitude and longitude values + ! to the cartesian x/y on a Lambert Conformal projection. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) ! Latitude (-90->90 deg N) + real, intent(in) :: lon(:) ! Longitude (-180->180 E) + type(proj_info),intent(in) :: proj ! Projection info structure + + real, intent(out) :: x(:) ! Cartesian X coordinate + real, intent(out) :: y(:) ! Cartesian Y coordinate + + real, allocatable :: arg(:) + real, allocatable :: deltalon(:) + real :: tl1r + real, allocatable :: rm(:) + real :: ctl1r + integer :: n + + if (trace_use_dull) call da_trace_entry("da_llxy_lc_1d") + + n = size(lat) + allocate ( arg(n), deltalon(n), rm(n) ) + + ! Compute deltalon between known longitude and standard lon and ensure + ! it is not in the cut zone + deltalon = lon - proj%stdlon + where (deltalon > +180.0) deltalon = deltalon - 360.0 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + + ! Convert truelat1 to radian and compute COS for later use + tl1r = proj%truelat1 * rad_per_deg + ctl1r = COS(tl1r) + + ! Radius to desired point + rm = proj%rebydx * ctl1r/proj%cone * & + (TAN((90.0*proj%hemi-lat)*rad_per_deg/2.0) / & + TAN((90.0*proj%hemi-proj%truelat1)*rad_per_deg/2.0))**proj%cone + + arg = proj%cone*(deltalon*rad_per_deg) + x = proj%polei + proj%hemi * rm * Sin(arg) + y = proj%polej - rm * COS(arg) + + ! Finally, if we are in the southern hemisphere, flip the i/j + ! values to a coordinate system where (1,1) is the SW corner + ! (what we assume) which is different than the original NCEP + ! algorithms which used the NE corner as the origin in the + ! southern hemisphere (left-hand vs. right-hand coordinate?) + if (proj%hemi == -1.0) then + x = 2.0 - x + y = 2.0 - y + end if + + deallocate ( arg, deltalon, rm ) + + if (trace_use_dull) call da_trace_exit("da_llxy_lc_1d") + +end subroutine da_llxy_lc_1d + + diff --git a/var/da/da_tools/da_llxy_merc_1d.inc b/var/da/da_tools/da_llxy_merc_1d.inc new file mode 100644 index 0000000000..ef39acf721 --- /dev/null +++ b/var/da/da_tools/da_llxy_merc_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_merc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute x,y coordinate from lat lon for mercator projection + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + real,intent(out) :: x(:) + real,intent(out) :: y(:) + real, allocatable :: deltalon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_merc_1d") + + n = size(lat) + allocate ( deltalon(n) ) + + deltalon = lon - proj%lon1 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + where (deltalon > 180.0) deltalon = deltalon - 360.0 + x = 1.0 + (deltalon/(proj%dlon*deg_per_rad)) + y = 1.0 + (ALOG(TAN(0.5*((lat + 90.0) * rad_per_deg)))) / & + proj%dlon - proj%rsw + + deallocate ( deltalon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_merc_1d") + +end subroutine da_llxy_merc_1d + + diff --git a/var/da/da_tools/da_llxy_ps_1d.inc b/var/da/da_tools/da_llxy_ps_1d.inc new file mode 100644 index 0000000000..3c39cfb9fb --- /dev/null +++ b/var/da/da_tools/da_llxy_ps_1d.inc @@ -0,0 +1,50 @@ +subroutine da_llxy_ps_1d(lat,lon,proj,x,y) + + !----------------------------------------------------------------------- + ! Purpose: Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the x/y indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + + real, intent(out) :: x(:) !(x-index) + real, intent(out) :: y(:) !(y-index) + + real :: reflon + real :: scale_top + real, allocatable :: ala(:) + real, allocatable :: alo(:) + real, allocatable :: rm(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_ps_1d") + + reflon = proj%stdlon + 90.0 + + ! Compute numerator term of map scale factor + + scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg) + + ! Find radius to desired point + n = size(lat) + allocate ( ala(n), alo(n), rm(n) ) + + ala = lat * rad_per_deg + rm = proj%rebydx * COS(ala) * scale_top/(1.0 + proj%hemi *Sin(ala)) + alo = (lon - reflon) * rad_per_deg + x = proj%polei + rm * COS(alo) + y = proj%polej + proj%hemi * rm * Sin(alo) + + deallocate ( ala, alo, rm ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_ps_1d") + +end subroutine da_llxy_ps_1d + + diff --git a/var/da/da_tools/da_llxy_rotated_latlon_1d.inc b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc new file mode 100644 index 0000000000..bc802c4da8 --- /dev/null +++ b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc @@ -0,0 +1,60 @@ +subroutine da_llxy_rotated_latlon_1d(lat,lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a rotated LATLON grid. + ! Author : Syed RH Rizvi, MMM/NCAR + ! 06/01/2008 + !--------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: rot_lat(:), rot_lon(:), deltalat(:), deltalon(:), lon360(:) + real, allocatable :: xlat(:), xlon(:) + real :: cen_lat, cen_lon, latinc, loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_rotated_latlon_1d") + + n = size(lat) + allocate ( rot_lat(n), rot_lon(n), deltalat(n), deltalon(n), lon360(n), xlat(n), xlon(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + xlat = deg_to_rad*lat + xlon = deg_to_rad*lon360 + cen_lat = deg_to_rad*proj%lat1 + cen_lon = deg_to_rad*proj%lon1 + if (cen_lon < 0.) cen_lon = cen_lon + 360. + + latinc = proj%latinc + loninc = proj%loninc + + rot_lon = rad_to_deg*atan( cos(xlat) * sin(xlon-cen_lon)/ & + (cos(cen_lat)*cos(xlat)*cos(xlon-cen_lon) + sin(cen_lat)*sin(xlat))) + rot_lat = rad_to_deg*asin( cos(cen_lat)*sin(xlat) - sin(cen_lat)*cos(xlat)*cos(xlon-cen_lon)) + + + deltalat = rot_lat + deltalon = rot_lon + + ! Compute x/y + x = proj%knowni + deltalon/loninc + 1.0 + y = proj%knownj + deltalat/latinc + 1.0 + + deallocate ( rot_lat, rot_lon, deltalat, deltalon, lon360, xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_rotated_latlon_1d") + +end subroutine da_llxy_rotated_latlon_1d diff --git a/var/da/da_tools/da_llxy_wrf_1d.inc b/var/da/da_tools/da_llxy_wrf_1d.inc new file mode 100644 index 0000000000..4a46d9b34c --- /dev/null +++ b/var/da/da_tools/da_llxy_wrf_1d.inc @@ -0,0 +1,51 @@ +subroutine da_llxy_wrf_1d(proj, lat, lon, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Converts input lat/lon values to the cartesian (x, y) value + ! for the given projection. + !----------------------------------------------------------------------- + + implicit none + + type(proj_info), intent(in) :: proj + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + if (trace_use_frequent) call da_trace_entry("da_llxy_wrf_1d") + + if (.NOT.proj%init) then + call da_error(__FILE__,__LINE__, & + (/"You have not called map_set for this projection!"/)) + end if + + select case(proj%code) + + case(PROJ_LATLON) + call da_llxy_latlon_1d(lat,lon,proj,x,y) + + case(PROJ_MERC) + call da_llxy_merc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case(PROJ_PS) + call da_llxy_ps_1d(lat,lon,proj,x,y) + + case(PROJ_LC) + call da_llxy_lc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case default + write(unit=message(1),fmt='(A,I2)') & + 'Unrecognized map projection code: ', proj%code + call da_error(__FILE__,__LINE__,message(1:1)) + end select + + if (trace_use_frequent) call da_trace_exit("da_llxy_wrf_1d") + +end subroutine da_llxy_wrf_1d + + diff --git a/var/da/da_tools/da_togrid_1d.inc b/var/da/da_tools/da_togrid_1d.inc new file mode 100644 index 0000000000..262a446e7f --- /dev/null +++ b/var/da/da_tools/da_togrid_1d.inc @@ -0,0 +1,44 @@ +subroutine da_togrid_1d (x, ib, ie, i, dx, dxm) + + !----------------------------------------------------------------------- + ! Purpose: Transfer obs. x to grid i and calculate its + ! distance to grid i and i+1 + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: x(:) + integer, intent(in) :: ib, ie + real, intent(out) :: dx(:), dxm(:) + integer, intent(out) :: i(:) + + if (trace_use) call da_trace_entry("da_togrid_1d") + +! where (x(:) > 0.0) +! i = int (x) +! +! where(i(:) < ib) i = ib +! where(i(:) >= ie) i = ie-1 +! +! dx = x - real(i) +! dxm = 1.0 - dx +! elsewhere +! i = 0 +! dx = 0.0 +! dxm = 0.0 +! end where + + i = int (x) + where (i(:) < ib) + i = ib + elsewhere (i(:) >= ie) + i = ie - 1 + end where + dx = x - real(i) + dxm = 1.0 - dx + + if (trace_use) call da_trace_exit("da_togrid_1d") + +end subroutine da_togrid_1d + + diff --git a/var/da/da_tools/da_tools.f90 b/var/da/da_tools/da_tools.f90 index ced8aa918b..fa5247d1c1 100644 --- a/var/da/da_tools/da_tools.f90 +++ b/var/da/da_tools/da_tools.f90 @@ -65,6 +65,18 @@ module da_tools #include "da_llxy_ps_new.inc" #include "da_llxy_wrf.inc" #include "da_llxy_wrf_new.inc" + +#include "da_llxy_1d.inc" +#include "da_llxy_default_1d.inc" +#include "da_llxy_kma_global_1d.inc" +#include "da_llxy_global_1d.inc" +#include "da_llxy_rotated_latlon_1d.inc" +#include "da_llxy_latlon_1d.inc" +#include "da_llxy_lc_1d.inc" +#include "da_llxy_merc_1d.inc" +#include "da_llxy_ps_1d.inc" +#include "da_llxy_wrf_1d.inc" + #include "da_xyll.inc" #include "da_xyll_default.inc" #include "da_xyll_latlon.inc" @@ -98,6 +110,7 @@ module da_tools #include "da_smooth_anl.inc" #include "da_togrid_new.inc" #include "da_togrid.inc" +#include "da_togrid_1d.inc" #include "da_unifva.inc" #include "da_buddy_qc.inc" diff --git a/var/run/VARBC.in b/var/run/VARBC.in index 247053c015..8c407c79eb 100644 --- a/var/run/VARBC.in +++ b/var/run/VARBC.in @@ -1,5 +1,5 @@ VARBC version 1.0 - Number of instruments: - 48 + 49 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ @@ -2405,6 +2405,25 @@ 8 8 0 0 0 0 0 -1 -1 -1 -0.600 0.000 0.000 0.000 0.000 9 9 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 10 10 0 0 0 0 0 -1 -1 -1 -2.000 0.000 0.000 0.000 0.000 + ------------------------------------------------ + Platform_id Sat_id Sensor_id Nchanl Npredmax + ------------------------------------------------ + 4 16 44 10 8 + -----> Bias predictor statistics: Mean & Std & Nbgerr + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 10000 10000 10000 10000 10000 10000 10000 10000 + -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param + 1 1 0 0 0 0 0 -1 -1 -1 2.100 0.000 0.000 0.000 0.000 + 2 2 0 0 0 0 0 -1 -1 -1 0.299 0.000 -0.001 -0.006 0.009 + 3 3 0 0 0 0 0 -1 -1 -1 0.516 0.001 -0.005 0.000 0.019 + 4 4 0 0 0 0 0 -1 -1 -1 -0.095 -0.005 0.001 -0.002 0.024 + 5 5 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 6 6 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 7 7 0 0 0 0 0 -1 -1 -1 -0.800 0.000 0.000 0.000 0.000 + 8 8 0 0 0 0 0 -1 -1 -1 -0.600 0.000 0.000 0.000 0.000 + 9 9 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 10 10 0 0 0 0 0 -1 -1 -1 -2.000 0.000 0.000 0.000 0.000 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info new file mode 100644 index 0000000000..7c3cd410c8 --- /dev/null +++ b/var/run/radiance_info/goes-16-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 2.7200000000E+00 0.0000000000E+00 25.00000 12.00000 + 1023 8 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 + 1023 9 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 + 1023 10 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 + 1023 12 1 -1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 + 1023 13 1 -1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 14 1 -1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 15 1 -1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 16 1 -1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info new file mode 100644 index 0000000000..db8322f635 --- /dev/null +++ b/var/run/radiance_info/goes-17-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 12 1 -1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 13 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 14 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 15 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 16 1 -1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 diff --git a/wrftladj/module_microphysics_driver_ad.F b/wrftladj/module_microphysics_driver_ad.F index de436b2263..ead30bf2cc 100755 --- a/wrftladj/module_microphysics_driver_ad.F +++ b/wrftladj/module_microphysics_driver_ad.F @@ -55,8 +55,7 @@ SUBROUTINE A_MICROPHYSICS_DRIVER(th, thb, rho, rhob, pi_phy, pi_phyb, p& USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, WSM6RSCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN & - ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM & ,MILBRANDT2MOM, LSCONDSCHEME, MKESSLERSCHEME, CAMMGMPSCHEME, NTU !,MILBRANDT3MOM, ntu3m ! Model Layer @@ -77,7 +76,6 @@ SUBROUTINE A_MICROPHYSICS_DRIVER(th, thb, rho, rhob, pi_phy, pi_phyb, p& IMPLICIT NONE -! ,NSSL_3MOM & !,MILBRANDT3MOM ! Model Layer ! *** add new modules of schemes here diff --git a/wrftladj/module_microphysics_driver_tl.F b/wrftladj/module_microphysics_driver_tl.F index ea57bfbb4d..2562f4d5ae 100755 --- a/wrftladj/module_microphysics_driver_tl.F +++ b/wrftladj/module_microphysics_driver_tl.F @@ -51,8 +51,7 @@ SUBROUTINE G_MICROPHYSICS_DRIVER(th, thd, rho, rhod, pi_phy, pi_phyd, p& USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, WSM6RSCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & - ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM & ,MILBRANDT2MOM, LSCONDSCHEME, MKESSLERSCHEME, CAMMGMPSCHEME, NTU !,MILBRANDT3MOM, ntu3m ! Model Layer @@ -72,7 +71,6 @@ SUBROUTINE G_MICROPHYSICS_DRIVER(th, thd, rho, rhod, pi_phy, pi_phyd, p& IMPLICIT NONE -! ,NSSL_3MOM & !,MILBRANDT3MOM ! Model Layer ! *** add new modules of schemes here diff --git a/wrftladj/module_pbl_driver_ad.F b/wrftladj/module_pbl_driver_ad.F index 27fc22efbe..3001a38490 100644 --- a/wrftladj/module_pbl_driver_ad.F +++ b/wrftladj/module_pbl_driver_ad.F @@ -502,6 +502,10 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& REAL :: seamask, thsk, zzz, unew, vnew, tnew, qnew, umom, vmom REAL :: z0, z1, z2, w1, w2 !------------------------------------------------------------------ +! For shared physics + REAL, DIMENSION(ims:ime, jms:jme) :: dx2dtmp + character*256 :: errmsg + integer :: errflg ! !!!!!!!if using BEP set flag_bep to true INTEGER :: branch @@ -635,6 +639,7 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& ELSE CALL PUSHCONTROL1B(1) END IF + dx2dtmp(i,j)=dx END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) @@ -677,8 +682,9 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& & oc12d=oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4& & , ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, & & SINA=sina,COSA=cosa, znu=znu, & +& errmsg= errmsg, errflg=errflg, & & znw=znw, p_top=p_top, cp=cp, g=g, rd=r_d, rv=& -& r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx, kpbl2d=& +& r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx2dtmp, kpbl2d=& & kpbl, itimestep=itimestep, ids=ids, ide=ide, jds=jds, & & jde=jde, kds=kds, kde=kde, ims=ims, ime=ime, jms=jms, & & jme=jme, kms=kms, kme=kme, its=its, ite=ite, jts=jts, &